From 7951a843612a76ec57d818bf190429c3c53fddfc Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 31 Dec 2019 19:31:38 +0000 Subject: [PATCH 001/212] fix divide by zero --- src/user/MOM_wave_interface.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 0da6285f37..042df7c02f 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1069,10 +1069,14 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) sqrt( 2.0 * PI *kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) - else - UStokes_sl = 0.0 - LA=1.e8 + if(UStokes_sl .ne. 0.0)then + LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) + else + LA=1.e8 + endif + !else + ! UStokes_sl = 0.0 + ! LA=1.e8 endif end subroutine Get_StokesSL_LiFoxKemper From ae51d44ecafafaa5cab4da3fefc1ed71fb5cf7b8 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 31 Dec 2019 20:42:16 +0000 Subject: [PATCH 002/212] fix to wave_interface for debugging; looked safe but gave error about mixed complex and real variables --- src/user/MOM_wave_interface.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 042df7c02f..88a29f5577 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1072,11 +1072,12 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) if(UStokes_sl .ne. 0.0)then LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) else - LA=1.e8 + UStokes_sl = 0.0 + LA=1.e8 endif - !else - ! UStokes_sl = 0.0 - ! LA=1.e8 + else + UStokes_sl = 0.0 + LA=1.e8 endif end subroutine Get_StokesSL_LiFoxKemper From 40871c180d0497029e90ac0776f5340ac4573765 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 1 Jan 2020 13:07:09 +0000 Subject: [PATCH 003/212] more better way of fixing divide by zero --- src/user/MOM_wave_interface.F90 | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 88a29f5577..2d2e3cafd3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1022,6 +1022,8 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, lasl_sqr_i real :: u10 + UStokes_sl = 0.0 + LA=1.e8 if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(GV%Rho0/1.225), u10, GV, US) @@ -1069,15 +1071,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) sqrt( 2.0 * PI *kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - if(UStokes_sl .ne. 0.0)then - LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) - else - UStokes_sl = 0.0 - LA=1.e8 - endif - else - UStokes_sl = 0.0 - LA=1.e8 + if(UStokes_sl .ne. 0.0)LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) endif end subroutine Get_StokesSL_LiFoxKemper From 8c23ae9ad74f5d9098e88dc222b2394ed042eff3 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 13 Jan 2020 11:58:43 -0500 Subject: [PATCH 004/212] fix divide by zero in wave_interface which allows for running in debug mode for NEMS (#12) --- src/user/MOM_wave_interface.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 0da6285f37..2d2e3cafd3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1022,6 +1022,8 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, lasl_sqr_i real :: u10 + UStokes_sl = 0.0 + LA=1.e8 if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(GV%Rho0/1.225), u10, GV, US) @@ -1069,10 +1071,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) sqrt( 2.0 * PI *kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) - else - UStokes_sl = 0.0 - LA=1.e8 + if(UStokes_sl .ne. 0.0)LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) endif end subroutine Get_StokesSL_LiFoxKemper From a446d0fb21c2efa4e12efdd0530581d8498640a2 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 2 Mar 2020 12:34:17 -0500 Subject: [PATCH 005/212] Remove dependence on the boundary layer scheme --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 8 ++++---- src/tracer/MOM_neutral_diffusion.F90 | 16 ++++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 4fda621abc..adbe6b8b98 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -92,9 +92,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab 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 +! 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, "LATERAL_BOUNDARY_METHOD", CS%method, & @@ -151,7 +151,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real :: Idt !< inverse of the time step [s-1] Idt = 1./dt - hbl(:,:) = 0. + hbl(:,:) = 100. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index f569c81bbc..e2061a689b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -211,13 +211,13 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic default = .true.) endif - if (CS%interior_only) then - 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 - call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") - endif - endif +! if (CS%interior_only) then +! 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 +! call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") +! endif +! endif ! call get_param(param_file, mdl, "KHTR", CS%KhTr, & ! "The background along-isopycnal tracer diffusivity.", & @@ -293,7 +293,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! check if hbl needs to be extracted if (CS%interior_only) then - hbl(:,:) = 0. + hbl(:,:) = 100. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) From b5132d99d929f8e54855e55e30badfd91ee95afd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Mar 2020 09:26:34 -0600 Subject: [PATCH 006/212] Modifications to run idealized two-column LBD * turned off pressure force * hard-coded BLD * turned off advect_tracer * set NTR = 2 --- src/core/MOM.F90 | 6 ++++-- src/core/MOM_dynamics_unsplit.F90 | 15 +++++++++------ src/tracer/MOM_lateral_boundary_diffusion.F90 | 1 + src/tracer/MOM_neutral_diffusion.F90 | 1 + src/tracer/tracer_example.F90 | 2 +- 5 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3348cc1212..0de9b793b0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -983,6 +983,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE) else + ! GMM do nothing call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) @@ -1087,8 +1088,9 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) - call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & - CS%tracer_adv_CSp, CS%tracer_Reg) + ! GMM, turn off advection +! call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & +! CS%tracer_adv_CSp, CS%tracer_Reg) call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index ed7c440010..ccf9425492 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -308,8 +308,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) +! GMM, turn off pressure force +! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & +! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then @@ -377,8 +378,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) +! GMM, turn off pressure force +! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & +! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then @@ -456,8 +458,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! PFu = d/dx M(h_av,T,S) call cpu_clock_begin(id_clock_pres) - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) +! GMM, turn off pressure force +! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & +! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index adbe6b8b98..9479e32a79 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -152,6 +152,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 100. + hbl(4:6,:) = 50. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e2061a689b..004c3ea8bc 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -294,6 +294,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! check if hbl needs to be extracted if (CS%interior_only) then hbl(:,:) = 100. + hbl(4:6,:) = 50. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index c5e8f669c6..e316614419 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -29,7 +29,7 @@ module USER_tracer_example public USER_register_tracer_example, USER_initialize_tracer, USER_tracer_stock public tracer_column_physics, USER_tracer_surface_state, USER_tracer_example_end -integer, parameter :: NTR = 1 !< The number of tracers in this module. +integer, parameter :: NTR = 2 !< The number of tracers in this module. !> The control structure for the USER_tracer_example module type, public :: USER_tracer_example_CS ; private From 51a4d2e119dc5dc5341a5c1fe90e78d2601f6179 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Mar 2020 12:46:29 -0600 Subject: [PATCH 007/212] Apply a linear transition in LBD methods 1, 2 This commit adds a linear transition from full LBD at k=k_min to zero LBD at k=k_max. This is applied to both methods currently available in the LBD module. Another modification is the fact that both methods no longer compute average values at k_min (done previously via average_value_ppoly). Instead, the full layer thicknesses are now used. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 74 +++++++++++++------ 1 file changed, 50 insertions(+), 24 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 9479e32a79..b250060449 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -454,7 +454,9 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] real :: htot !< Total column thickness [m] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively + integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively + integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -462,8 +464,9 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !!layer depth [nondim] real :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] - + real :: hbl_min !< minimum BLD (left and right) [m] + 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] F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return @@ -475,6 +478,9 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L 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) + ! make sure left and right k indices span same range if (k_bot_min .ne. k_bot_L) then k_bot_L = k_bot_min @@ -493,12 +499,21 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + !F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) - do k = k_bot_min-1,1,-1 + do k = k_bot_min,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo + + if (k_bot_diff .gt. 1) then + a = -1.0/k_bot_diff + do k = k_bot_min+1,k_bot_max-1, 1 + wgt = (a*(k-k_bot_min)) + 1.0 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + enddo + endif endif if (boundary == BOTTOM) then @@ -570,6 +585,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, !! [conc m^-3 ] real :: htot ! Total column thickness [m] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively + integer :: k_diff !< difference between k_max and k_min integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the @@ -580,7 +596,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] logical :: limited !< True if the flux limiter was applied - real :: hfrac, F_bulk_remain + real :: hfrac, F_bulk_remain, wgt, a if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. @@ -609,27 +625,37 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if (boundary == SURFACE) then k_min = MIN(k_bot_L, k_bot_R) - - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L - else - h_work_L = h_L(k_min) - endif - - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif - - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - - do k=1,k_min-1 + k_max = MAX(k_bot_L, k_bot_R) + k_diff = (k_max - k_min) + +! ! left hand side +! if (k_bot_L == k_min) then +! h_work_L = h_L(k_min) * zeta_bot_L +! else +! h_work_L = h_L(k_min) +! endif +! +! ! right hand side +! if (k_bot_R == k_min) then +! h_work_R = h_R(k_min) * zeta_bot_R +! else +! h_work_R = h_R(k_min) +! endif + +! h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + + do k=1,k_min h_means(k) = harmonic_mean(h_L(k),h_R(k)) enddo + if (k_diff .gt. 1) then + a = -1.0/k_diff + do k = k_min+1,k_max-1, 1 + wgt = (a*(k-k_min)) + 1.0 + h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt + enddo + endif + elseif (boundary == BOTTOM) then k_max = MAX(k_top_L, k_top_R) ! left hand side From f8bc91c14107c3fae5e1c139be911d9aeb75fea5 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 9 Apr 2020 10:42:43 -0400 Subject: [PATCH 008/212] Feature/logcleanup (#20) * cleanup of ESMF error handling Co-authored-by: Mariana Vertenstein --- config_src/nuopc_driver/mom_cap.F90 | 874 +++++--------------- config_src/nuopc_driver/mom_cap_methods.F90 | 215 ++--- config_src/nuopc_driver/mom_cap_time.F90 | 127 +-- config_src/nuopc_driver/time_utils.F90 | 30 +- 4 files changed, 298 insertions(+), 948 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..690b881375 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -132,7 +132,7 @@ module MOM_cap_mod integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 integer :: scalar_field_idx_grid_ny = 0 -character(len=*),parameter :: u_file_u = & +character(len=*),parameter :: u_FILE_u = & __FILE__ #ifdef CESMCOUPLED @@ -163,32 +163,20 @@ subroutine SetServices(gcomp, rc) ! the NUOPC model component will register the generic methods call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! switching to IPD versions call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & userRoutine=InitializeP0, phase=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! set entry point for methods that require specific implementation call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeAdvertise, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeRealize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! attach specializing method(s) @@ -196,36 +184,21 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & specRoutine=DataInitialize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & specRoutine=ModelAdvance, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & specRoutine=ModelSetRunClock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & specRoutine=ocean_model_finalize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine SetServices @@ -258,95 +231,54 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return write_diagnostics = .false. call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") write(logmsg,*) write_diagnostics - call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") write(logmsg,*) overwrite_timeslice - call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) profile_memory=(trim(value)=="true") write(logmsg,*) profile_memory - call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) grid_attach_area = .false. call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") write(logmsg,*) grid_attach_area - call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_count if (iostat /= 0) then @@ -356,20 +288,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then @@ -379,20 +304,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then @@ -402,19 +320,12 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif call NUOPC_CompAttributeAdd(gcomp, & attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine @@ -469,11 +380,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) allocate(Ice_ocean_boundary) !allocate(ocean_state) ! ocean_model_init allocate this pointer @@ -484,34 +391,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call fms_init(mpi_comm_mom) call constants_init @@ -521,10 +413,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) calendar select case (trim(calendar)) @@ -558,16 +447,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! get start/reference time call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) @@ -583,28 +466,16 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (is_root_pe()) then call NUOPC_CompAttributeGet(gcomp, name="diro", & isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", & isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresentDiro .and. isPresentLogfile) then call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) else logunit = output_unit endif @@ -615,19 +486,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) starttype = "" call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) starttype else call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + ESMF_LOGMSG_INFO) endif runtype = "" @@ -645,11 +509,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = "" @@ -662,41 +522,22 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & existflag=existflag, userRc=userRc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (existflag) then - call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO) endif call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then restartfile = trim(cvalue) - call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO) else call ESMF_LogWrite('MOM_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + ESMF_LOGMSG_WARNING) endif endif @@ -752,10 +593,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (len_trim(scalar_field_name) > 0) then call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") @@ -810,18 +648,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) do n = 1,fldsToOcn_num call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo do n = 1,fldsFrOcn_num call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo end subroutine InitializeAdvertise @@ -905,10 +737,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -919,16 +748,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------------------------- ! global mom grid size @@ -936,11 +759,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total @@ -949,19 +768,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe if (ntiles /= 1) then rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + 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 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! get start and end indices of each tile and their PET @@ -973,11 +784,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (debug > 0) then do n = 1,ntiles 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) enddo endif @@ -1010,23 +817,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (localPet == 0) then write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) @@ -1034,17 +832,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! recreate the mesh using the above distGrid EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Check for consistency of lat, lon and mask between mesh and mom6 grid call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) @@ -1052,25 +844,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1,numOwnedElements lonMesh(n) = ownedElemCoords(2*n-1) latMesh(n) = ownedElemCoords(2*n) end do elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) n = 0 @@ -1117,16 +900,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(maskMesh, mask) ! realize the import and export fields using the mesh call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return else if (geomtype == ESMF_GEOMTYPE_GRID) then @@ -1148,19 +925,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deBlockList(2,2,n) = ye(n) petMap(n) = pe(n) ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side enddo delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! rsd this assumes tripole grid, but sometimes in CESM a bipole ! grid is used -- need to introduce conditional logic here @@ -1171,18 +945,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! periodic boundary condition along first dimension call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & ! indexflag = ESMF_INDEX_DELOCAL, & @@ -1191,10 +959,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) delayout=delayout, & connectionList=connectionList, & rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(xb,xe,yb,ye,pe) deallocate(connectionList) @@ -1203,32 +968,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(petMap) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(indexList(cnt)) write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) deallocate(IndexList) @@ -1238,91 +989,55 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & coordSys = ESMF_COORDSYS_SPH_DEG, & rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Attach area to the Grid optionally. By default the cell areas are computed. if(grid_attach_area) then call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if(grid_attach_area) then call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! load up area, mask, center and corner values @@ -1345,13 +1060,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ubnd4 = ubound(dataPtr_xcor,2) write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & @@ -1390,38 +1105,32 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if(grid_attach_area) then write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) endif write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) gridOut = gridIn ! for now out same as in call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif @@ -1432,18 +1141,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (len_trim(scalar_field_name) > 0) then call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1457,10 +1159,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !call NUOPC_Write(exportState, fileNamePrefix='post_realize_field_ocn_export_', & ! timeslice=1, relaxedFlag=.true., rc=rc) - !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out + !if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine InitializeRealize @@ -1489,16 +1188,10 @@ subroutine DataInitialize(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1506,57 +1199,35 @@ subroutine DataInitialize(gcomp, rc) call get_ocean_grid(ocean_state, ocean_grid) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(fieldNameList(fieldCount)) call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return do n=1, fieldCount call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo deallocate(fieldNameList) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) endif if(write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif end subroutine DataInitialize @@ -1606,43 +1277,23 @@ subroutine ModelAdvance(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep call ESMF_ClockPrint(clock, options="currTime", & preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimePrint(currTime + timeStep, & preString="--------------------------------> to: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1656,11 +1307,7 @@ subroutine ModelAdvance(gcomp, rc) ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) do_advance = .false. else do_advance = .true. @@ -1669,18 +1316,10 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) Time_step_coupled = 2 * esmf2fms_time(timeStep) endif end if @@ -1691,10 +1330,7 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1707,10 +1343,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return import_slice = import_slice + 1 endif @@ -1725,10 +1358,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! Update MOM6 @@ -1743,10 +1373,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif @@ -1755,78 +1382,44 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! call into system specific method to get desired restart filename restartname = "" call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & existflag=existflag, userRc=userRc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (existflag) then - call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO) call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then restartname = trim(cvalue) - call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO) endif endif if (len_trim(restartname) == 0) then ! none provided, so use a default restart filename call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) endif ! TODO: address if this requirement is being met for the DA group @@ -1834,15 +1427,12 @@ subroutine ModelAdvance(gcomp, rc) ! if (restart_interval > 0 ) then ! time_elapsed = currTime - startTime ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return ! n_interval = time_elapsed_sec / restart_interval ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then ! time_restart_current = esmf2fms_time(currTime) ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO) ! write(*,*) 'calling ocean_model_restart' ! call ocean_model_restart(ocean_state, timestamp) ! endif @@ -1863,10 +1453,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return export_slice = export_slice + 1 endif @@ -1899,22 +1486,13 @@ subroutine ModelSetRunClock(gcomp, rc) ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! check that the current time in the model and driver are the same @@ -1922,16 +1500,10 @@ subroutine ModelSetRunClock(gcomp, rc) if (mcurrtime /= dcurrtime) then call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & @@ -1946,10 +1518,7 @@ subroutine ModelSetRunClock(gcomp, rc) mstoptime = mcurrtime + dtimestep call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (first_time) then !-------------------------------- @@ -1962,26 +1531,17 @@ subroutine ModelSetRunClock(gcomp, rc) call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & isSet=isSet, value=restart_option, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n endif call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd endif @@ -1996,24 +1556,13 @@ subroutine ModelSetRunClock(gcomp, rc) opt_ymd = restart_ymd, & RefTime = mcurrTime, & alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return first_time = .false. - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) endif @@ -2022,20 +1571,13 @@ subroutine ModelSetRunClock(gcomp, rc) !-------------------------------- call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine ModelSetRunClock - !=============================================================================== !> Called by NUOPC at the end of the run to clean up. @@ -2061,25 +1603,16 @@ subroutine ocean_model_finalize(gcomp, rc) rc = ESMF_SUCCESS call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr call NUOPC_ModelGet(gcomp, modelClock=clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(clock, currTime=currTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return Time = esmf2fms_time(currTime) if (cesm_coupled) then @@ -2116,16 +1649,15 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ rc = ESMF_SUCCESS call ESMF_StateGet(State, itemName=trim(scalar_name), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (mytask == 0) then call ESMF_FieldGet(field, farrayPtr=farrayptr, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (scalar_id < 0 .or. scalar_id > scalar_count) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ERROR in scalar_id", & - line=__LINE__, file=__FILE__, rcToReturn=rc) + msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) return endif @@ -2163,57 +1695,36 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) if (present(grid)) then field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return fldptr2d(:,:) = 0.0 else if (present(mesh)) then field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return fldptr1d(:) = 0.0 endif @@ -2222,24 +1733,16 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) ! Realize connected field call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return else ! field is not connected call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) + ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif @@ -2262,24 +1765,15 @@ subroutine SetScalarField(field, rc) ! create a DistGrid with a single index space element, which gets mapped onto DE 0. distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return grid = ESMF_GridCreate(distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! num of scalar values field = ESMF_FieldCreate(name=trim(scalar_field_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & ungriddedLBound=(/1/), ungriddedUBound=(/scalar_field_count/), gridToFieldMap=(/2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine SetScalarField @@ -2333,6 +1827,18 @@ subroutine shr_file_getLogUnit(nunit) end subroutine shr_file_getLogUnit #endif +logical function chkerr(rc, line, file) + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + integer :: lrc + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif +end function chkerr + !> !! @page nuopc_cap NUOPC Cap !! @author Fei Liu (fei.liu@gmail.com) diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 70915d0e95..2c69b504e0 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -43,6 +43,9 @@ module MOM_cap_methods type(ESMF_GeomType_Flag) :: geomtype !< SMF type describing type of !! geometry (mesh or grid) +character(len=*),parameter :: u_FILE_u = & + __FILE__ + contains !> Sets module variable geometry type @@ -86,60 +89,42 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- call state_getimport(importState, 'inst_pres_height_surface', & isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! zonal and meridional surface stress @@ -148,15 +133,9 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, allocate (tauy(isc:iec,jsc:jec)) call state_getimport(importState, 'mean_zonal_moment_flx', isc, iec, jsc, jec, taux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport(importState, 'mean_merid_moment_flx', isc, iec, jsc, jec, tauy, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! rotate taux and tauy from true zonal/meridional to local coordinates @@ -178,40 +157,28 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- call state_getimport(importState, 'mean_sensi_heat_flx', & isc, iec, jsc, jec, ice_ocean_boundary%t_flux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! mass and heat content of liquid and frozen runoff @@ -223,37 +190,25 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ice_ocean_boundary%lrunoff (:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'Foxx_rofl', & isc, iec, jsc, jec, ice_ocean_boundary%lrunoff,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ice runoff ice_ocean_boundary%frunoff (:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'Foxx_rofi', & isc, iec, jsc, jec, ice_ocean_boundary%frunoff,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! heat content of lrunoff ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'mean_runoff_heat_flx', & isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! heat content of frunoff ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'mean_calving_heat_flx', & isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! salt flux from ice @@ -261,10 +216,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, 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,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! !---- ! ! snow&ice melt heat flux (W/m^2) @@ -272,10 +224,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, 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,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! !---- ! ! snow&ice melt water flux (W/m^2) @@ -283,10 +232,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, 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,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! mass of overlying ice @@ -297,10 +243,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, 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) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine mom_import @@ -339,16 +282,10 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc = ESMF_SUCCESS call ESMF_ClockGet( clock, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeIntervalGet( timeStep, s=dt_int, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Use Adcroft's rule of reciprocals; it does the right thing here. if (real(dt_int) > 0.0) then @@ -378,10 +315,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, call State_SetExport(exportState, 'ocean_mask', & isc, iec, jsc, jec, omask, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(omask) @@ -390,20 +324,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call State_SetExport(exportState, 'sea_surface_temperature', & isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- ! zonal and meridional currents @@ -430,17 +358,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, call State_SetExport(exportState, 'ocn_current_zonal', & isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(ocz, ocm, ocz_rot, ocm_rot) @@ -451,10 +373,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then call State_SetExport(exportState, 'So_bldepth', & isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! ------- @@ -478,10 +397,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, call State_SetExport(exportState, 'freezing_melting_potential', & isc, iec, jsc, jec, melt_potential, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(melt_potential) @@ -492,10 +408,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then call State_SetExport(exportState, 'sea_level', & isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !---------------- @@ -598,17 +511,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, call State_SetExport(exportState, 'sea_surface_slope_zonal', & isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + 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) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) @@ -627,15 +534,9 @@ subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (present(rc)) rc = lrc @@ -654,15 +555,9 @@ subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (present(rc)) rc = lrc @@ -702,10 +597,7 @@ subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, r ! get field pointer call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! determine output array n = 0 @@ -723,10 +615,7 @@ subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, r else if (geomtype == ESMF_GEOMTYPE_GRID) then call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return lbnd1 = lbound(dataPtr2d,1) lbnd2 = lbound(dataPtr2d,2) @@ -786,10 +675,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid if (geomtype == ESMF_GEOMTYPE_MESH) then call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return n = 0 do j = jsc, jec @@ -804,10 +690,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid else if (geomtype == ESMF_GEOMTYPE_GRID) then call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return lbnd1 = lbound(dataPtr2d,1) lbnd2 = lbound(dataPtr2d,2) @@ -828,4 +711,16 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid end subroutine State_SetExport +logical function chkerr(rc, line, file) + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + integer :: lrc + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif +end function chkerr + end module MOM_cap_methods diff --git a/config_src/nuopc_driver/mom_cap_time.F90 b/config_src/nuopc_driver/mom_cap_time.F90 index daf9889c43..aa1a6c7072 100644 --- a/config_src/nuopc_driver/mom_cap_time.F90 +++ b/config_src/nuopc_driver/mom_cap_time.F90 @@ -125,22 +125,13 @@ subroutine AlarmInit( clock, alarm, option, & endif call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(CurrTime, yy=nyy, mm=nmm, dd=ndd, s=nsec, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! initial guess of next alarm, this will be updated below if (present(RefTime)) then @@ -151,25 +142,16 @@ subroutine AlarmInit( clock, alarm, option, & ! Determine calendar call ESMF_ClockGet(clock, calendar=cal, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Determine inputs for call to create alarm selectcase (trim(option)) case (optNONE, optNever) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. case (optDate) @@ -188,15 +170,9 @@ subroutine AlarmInit( clock, alarm, option, & return endif call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. case (optIfdays0) @@ -208,104 +184,65 @@ subroutine AlarmInit( clock, alarm, option, & return endif call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. case (optNSteps, optNStep) call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optNSeconds, optNSecond) call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optNMinutes, optNMinute) call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optNHours, optNHour) call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optNDays, optNDay) call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optNMonths, optNMonth) call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optMonthly) call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. case (optNYears, optNYear) call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return AlarmInterval = AlarmInterval * opt_n update_nextalarm = .true. case (optYearly) call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. case default @@ -332,10 +269,7 @@ subroutine AlarmInit( clock, alarm, option, & endif alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine AlarmInit @@ -378,10 +312,7 @@ subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) call date2ymd (ymd,yr,mon,day) call ESMF_TimeSet( Time, yy=yr, mm=mon, dd=day, s=ltod, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine TimeInit @@ -405,4 +336,16 @@ subroutine date2ymd (date, year, month, day) end subroutine date2ymd +logical function chkerr(rc, line, file) + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + integer :: lrc + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif +end function chkerr + end module MOM_cap_time diff --git a/config_src/nuopc_driver/time_utils.F90 b/config_src/nuopc_driver/time_utils.F90 index e995c1b697..db056f4bf5 100644 --- a/config_src/nuopc_driver/time_utils.F90 +++ b/config_src/nuopc_driver/time_utils.F90 @@ -34,6 +34,9 @@ module time_utils_mod public fms2esmf_time public string_to_date +character(len=*),parameter :: u_FILE_u = & + __FILE__ + contains !> Sets fms2esmf_cal_c to the corresponding ESMF calendar type @@ -90,10 +93,7 @@ function esmf2fms_time_t(time) call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, & calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return esmf2fms_time_t = set_date(yy, mm, dd, h, m, s) @@ -111,10 +111,7 @@ function esmf2fms_timestep(timestep) integer :: rc call ESMF_TimeIntervalGet(timestep, s=s, calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return esmf2fms_timestep = set_time(s, 0) @@ -142,10 +139,7 @@ function fms2esmf_time(time, calkind) call ESMF_TimeSet(fms2esmf_time, yy=yy, mm=mm, d=d, h=h, m=m, s=s, & calkindflag=l_calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end function fms2esmf_time @@ -166,4 +160,16 @@ function string_to_date(string, rc) end function string_to_date +logical function chkerr(rc, line, file) + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + integer :: lrc + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif +end function chkerr + end module time_utils_mod From 8d565ccdd2863107371581b97375b281ad6691f0 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 15 Apr 2020 08:13:20 -0400 Subject: [PATCH 009/212] nuopc_driver updates (#22) * allows control of MOM6 restarts and MOM6 intermediate restarts using nems.configure settings restart_n and restart_option. Fixes duplicate restart issue when running with CMEPS (#16). * when field dumping is turned on, all fields in import state and export state are written to single file with timestamped file name (#15) * moves call to data_override field lrunoff out of the enclosing do loop (#21 ) Co-authored-by: Mariana Vertenstein --- config_src/nuopc_driver/mom_cap.F90 | 416 ++++++++++++------ config_src/nuopc_driver/mom_cap_methods.F90 | 2 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 2 +- .../mom_surface_forcing_nuopc.F90 | 6 +- 4 files changed, 296 insertions(+), 130 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 690b881375..12b12cf717 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -70,6 +70,11 @@ module MOM_cap_mod use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet, ESMF_Array use ESMF, only: ESMF_ArrayCreate +use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE +use ESMF, only: ESMF_VMBroadcast +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled +use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -81,16 +86,17 @@ module MOM_cap_mod use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet use NUOPC_Model, only: NUOPC_ModelGet -use NUOPC_Model, & - model_routine_SS => SetServices, & - model_label_Advance => label_Advance, & - model_label_DataInitialize => label_DataInitialize, & - model_label_SetRunClock => label_SetRunClock, & - model_label_Finalize => label_Finalize +use NUOPC_Model, only: model_routine_SS => SetServices +use NUOPC_Model, only: model_label_Advance => label_Advance +use NUOPC_Model, only: model_label_DataInitialize => label_DataInitialize +use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock +use NUOPC_Model, only: model_label_Finalize => label_Finalize +use NUOPC_Model, only: SetVM implicit none; private public SetServices +public SetVM !> Internal state type with pointers to three types defined by MOM. type ocean_internalstate_type @@ -142,6 +148,7 @@ module MOM_cap_mod logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_GRID #endif +character(len=8) :: restart_mode = 'cmeps' contains @@ -323,10 +330,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -373,6 +376,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag integer :: userRc + integer :: localPet + integer :: iostat + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -514,31 +520,40 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) restartfile = "" if (runtype == "initial") then - ! startup (new run) - 'n' is needed below if we don't specify input_filename in input.nml + restartfile = "n" - else if (runtype == "continue") then ! hybrid or branch or continuos runs - ! optionally call into system-specific implementation to get restart file name - call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, file=__FILE__)) return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, file=__FILE__)) return ! bail out - if (existflag) then - call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO) - endif + else if (runtype == "continue") then ! hybrid or branch or continuos runs - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - restartfile = trim(cvalue) - call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO) - else - call ESMF_LogWrite('MOM_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING) - endif + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', 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) + return + endif + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif @@ -1174,12 +1189,17 @@ subroutine DataInitialize(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_StateItem_Flag) :: itemType type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid character(240) :: msgString + character(240) :: fldname + character(240) :: timestr integer :: fieldCount, n type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) @@ -1190,6 +1210,11 @@ subroutine DataInitialize(gcomp, rc) call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1220,14 +1245,25 @@ subroutine DataInitialize(gcomp, rc) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif if(write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(field, fileName='field_init_ocn_export_'//trim(timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo endif end subroutine DataInitialize @@ -1245,13 +1281,15 @@ subroutine ModelAdvance(gcomp, rc) logical :: existflag, isPresent, isSet logical :: do_advance = .true. type(ESMF_Clock) :: clock!< ESMF Clock class definition - type(ESMF_Alarm) :: alarm + type(ESMF_Alarm) :: restart_alarm, stop_alarm type(ESMF_State) :: importState, exportState type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep type(ESMF_Time) :: startTime type(ESMF_TimeInterval) :: time_elapsed integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() @@ -1267,6 +1305,14 @@ subroutine ModelAdvance(gcomp, rc) integer :: seconds, day, year, month, hour, minute character(ESMF_MAXSTR) :: restartname, cvalue character(240) :: msgString + character(ESMF_MAXSTR) :: casename + integer :: iostat + integer :: writeunit + integer :: localPet + type(ESMF_VM) :: vm + integer :: n + character(240) :: import_timestr, export_timestr + character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' rc = ESMF_SUCCESS @@ -1295,6 +1341,9 @@ subroutine ModelAdvance(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) + Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1341,10 +1390,20 @@ subroutine ModelAdvance(gcomp, rc) !--------------- if (write_diagnostics) then - call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - import_slice = import_slice + 1 + do n = 1,fldsToOcn_num + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo endif !--------------- @@ -1378,65 +1437,80 @@ subroutine ModelAdvance(gcomp, rc) endif !--------------- - ! If restart alarm is ringing - write restart file + ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------- + ! If restart alarm exists and is ringing - write restart file + !--------------- - ! call into system specific method to get desired restart filename - restartname = "" - call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, file=__FILE__)) return ! bail out - - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, file=__FILE__)) return ! bail out - if (existflag) then - call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO) - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & - isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - restartname = trim(cvalue) - call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO) + if (restart_mode == 'cmeps') then + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & + trim(casename), year, month, day, seconds + 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) + 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) + return + endif + write(writeunit,'(a)') trim(restartname)//'.nc' + close(writeunit) endif - endif - - if (len_trim(restartname) == 0) then - ! none provided, so use a default restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & - h=hour, m=minute, s=seconds, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) - endif - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif + else + ! write the final restart without a timestamp + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"MOM.res" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + "MOM.res.", year, month, day, hour, minute, seconds + endif + end if + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname) @@ -1444,17 +1518,28 @@ subroutine ModelAdvance(gcomp, rc) if (is_root_pe()) then write(logunit,*) subname//' writing restart file ',trim(restartname) endif - endif + endif + end if ! end of restart_mode is cmeps !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - export_slice = export_slice + 1 + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_export_'//trim(export_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1469,17 +1554,19 @@ subroutine ModelSetRunClock(gcomp, rc) ! local variables type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime - type(ESMF_Time) :: mstoptime + type(ESMF_Time) :: mstoptime, dstoptime type(ESMF_TimeInterval) :: mtimestep, dtimestep character(len=128) :: mtimestring, dtimestring 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) - type(ESMF_ALARM) :: restart_alarm + 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 !-------------------------------- rc = ESMF_SUCCESS @@ -1488,7 +1575,8 @@ subroutine ModelSetRunClock(gcomp, rc) call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=dstoptime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) @@ -1529,12 +1617,14 @@ subroutine ModelSetRunClock(gcomp, rc) restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & - isSet=isSet, value=restart_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + if (cesm_coupled) then + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n @@ -1545,25 +1635,93 @@ subroutine ModelSetRunClock(gcomp, rc) if (isPresent .and. isSet) then read(cvalue,*) restart_ymd endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + else - restart_option = "none" + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + ! If restart_n is set and non-zero, then restart_option must be available from config + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) restart_n + if(restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_option must be set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + ! not used in nems + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) + endif + else + ! restart_n is zero, restart_mode will be nems + restart_mode = 'nems' + call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) + endif + else + ! restart_n is not set, restart_mode will be nems + restart_mode = 'nems' + call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) + endif endif - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'alarm_restart', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (restart_mode == 'cmeps') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) + end if + + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return first_time = .false. - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) - endif !-------------------------------- @@ -1597,6 +1755,7 @@ subroutine ocean_model_finalize(gcomp, rc) type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime character(len=64) :: timestamp + logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' write(*,*) 'MOM: --- finalize called ---' @@ -1615,11 +1774,16 @@ subroutine ocean_model_finalize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return Time = esmf2fms_time(currTime) - if (cesm_coupled) then - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.false.) + ! Do not write a restart unless mode is nems + if (restart_mode == 'nems') then + write_restart = .true. else - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.true.) - endif + write_restart = .false. + end if + if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & + ESMF_LOGMSG_INFO) + + call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() call fms_io_exit() diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 2c69b504e0..f1be8a3ea3 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -681,7 +681,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid do j = jsc, jec jg = j + ocean_grid%jsc - jsc do i = isc, iec - ig = i + ocean_grid%isc - isc + ig = i + ocean_grid%isc - isc n = n+1 dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 202fa5791d..0245d9633d 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -730,7 +730,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time, write_restart) type(time_type), intent(in) :: Time !< The model time, used for writing restarts. logical, intent(in) :: write_restart !< true => write restart file - call ocean_model_save_restart(Ocean_state, Time) + if(write_restart)call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index b75ff96532..7f729e3c3e 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -426,7 +426,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call MOM_error(FATAL, "liquid runoff is being added via data_override but "// & "there is no associated runoff in the IOB") return - end if + endif + if (associated(IOB%lrunoff)) then + if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) + endif ! obtain fluxes from IOB; note the staggering of indices i0 = is - isc_bnd ; j0 = js - jsc_bnd @@ -443,7 +446,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! liquid runoff flux if (associated(IOB%lrunoff)) then - if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%lrunoff(i-i0,j-j0) * G%mask2dT(i,j) endif From 9dc47208a15846ebe1399b7a5d1407ceca3550fc Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 5 May 2020 10:24:36 -0600 Subject: [PATCH 010/212] Add option to apply linear decay at the base of hbl This patch adds the option to apply a linear decay of the fluxes at the base of hbl. This had been already implemented but since it breaks the unit tests, which were designed to work without this option, adding this option will avoid breaking the tests. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 141 +++++++++++------- 1 file changed, 90 insertions(+), 51 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 0e2d656d5b..58fa8e6cc0 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -36,15 +36,18 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lateral_boundary_diffusion_CS ; private - integer :: method !< Determine which of the three methods calculate - !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer - integer :: deg !< Degree of polynomial reconstruction - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP - logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 1. + integer :: method !< Determine which of the three methods calculate + !! and apply near boundary layer fluxes + !! 1. Bulk-layer approach + !! 2. Along layer + integer :: deg !< Degree of polynomial reconstruction + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls wether a flux limiter is applied. + !! Only valid when method = 1. + 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. + 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 @@ -94,6 +97,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) CS%surface_boundary_scheme = -1 + !GMM, uncomment below ! 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 @@ -108,6 +112,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "If True, apply a flux limiter in the LBD. This is only available \n"//& "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) endif + 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, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -193,7 +200,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter) + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -203,7 +211,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter) + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -216,18 +225,20 @@ subroutine lateral_boundary_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, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) 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, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo @@ -428,7 +439,8 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method2 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & + F_layer, linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] @@ -450,7 +462,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point [m^3 conc] - + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] @@ -474,11 +487,18 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: hbl_min !< minimum BLD (left and right) [m] 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] + logical :: linear !< True if apply a linear transition + F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -506,24 +526,30 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - !F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) - - do k = k_bot_min,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - enddo + if ((linear) .and. (k_bot_diff .gt. 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo - if (k_bot_diff .gt. 1) then a = -1.0/k_bot_diff do k = k_bot_min+1,k_bot_max-1, 1 wgt = (a*(k-k_bot_min)) + 1.0 heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt enddo + else + F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + do k = k_bot_min-1,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo endif endif 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 .ne. k_top_L) then @@ -556,7 +582,7 @@ end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' !! See \ref section_method1 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] @@ -580,7 +606,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^3 conc] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^3 conc] logical, optional, intent(in ) :: F_limit !< If True, apply a limiter - logical, optional, intent(in ) :: linear !< If True, apply a limiter + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] @@ -604,10 +631,13 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] logical :: limiter !< True if flux limiter should be applied + logical :: linear !< True if apply a linear transition real :: hfrac !< Layer fraction wrt sum of all layers [nondim] real :: dphi !< tracer gradient [conc m^-3] - real :: wgt, a - + 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] if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. F_layer(:) = 0. @@ -618,6 +648,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if (PRESENT(F_limit)) then limiter = F_limit endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) @@ -642,35 +676,40 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, k_max = MAX(k_bot_L, k_bot_R) k_diff = (k_max - k_min) -! ! left hand side -! if (k_bot_L == k_min) then -! h_work_L = h_L(k_min) * zeta_bot_L -! else -! h_work_L = h_L(k_min) -! endif -! -! ! right hand side -! if (k_bot_R == k_min) then -! h_work_R = h_R(k_min) * zeta_bot_R -! else -! h_work_R = h_R(k_min) -! endif - -! h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - - do k=1,k_min - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - - if (k_diff .gt. 1) then + if ((linear) .and. (k_diff .gt. 1)) then + do k=1,k_min + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + ! fluxes will decay linearly at base of hbl a = -1.0/k_diff do k = k_min+1,k_max-1, 1 wgt = (a*(k-k_min)) + 1.0 h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt enddo + else + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif + + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif + + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo endif elseif (boundary == BOTTOM) then + !TODO, GMM linear decay is not implemented here k_max = MAX(k_top_L, k_top_R) ! left hand side if (k_top_L == k_max) then From bbdef39ae9e48c74f3f82a1d6ed4f8ac358b37dc Mon Sep 17 00:00:00 2001 From: Jessica Meixner Date: Wed, 13 May 2020 14:23:35 -0400 Subject: [PATCH 011/212] Updates for wave coupling in NUOPC (#23) * Adding extra ensemble slot for waves. * Updates for wave coupling - Adding wave information to mech_forcing type to pass from ice_ocean_boundary to wave types - This is only set-up to read surface Stokes drift and guess the wavelength as something reasonable for now to demonstrate that it works. This needs to be set-up properly before merging this into the main repository. * Updates to make Stokes drift from multiple bands work with the coupler approach * Adding wave stokes drift import to nuopc cap Co-authored-by: Brandon Reichl --- .../MOM_surface_forcing_gfdl.F90 | 27 ++- config_src/coupled_driver/ocean_model_MOM.F90 | 2 +- config_src/nuopc_driver/mom_cap.F90 | 25 +++ config_src/nuopc_driver/mom_cap_methods.F90 | 52 +++++ .../nuopc_driver/mom_ocean_model_nuopc.F90 | 9 +- .../mom_surface_forcing_nuopc.F90 | 32 ++- src/core/MOM_forcing_type.F90 | 25 ++- src/user/MOM_wave_interface.F90 | 188 ++++++++++++------ 8 files changed, 289 insertions(+), 71 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 9743c7fa3f..187f8ab7b2 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -189,6 +189,12 @@ module MOM_surface_forcing_gfdl !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model [m3 s-1] + real, pointer, dimension(:,:) :: ustk0 => NULL() !< + real, pointer, dimension(:,:) :: vstk0 => NULL() !< + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields !! used for passive tracer fluxes. @@ -196,6 +202,7 @@ module MOM_surface_forcing_gfdl !! This flag may be set by the flux-exchange code, based on what !! the sea-ice model is providing. Otherwise, the value from !! the surface_forcing_CS is used. + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler end type ice_ocean_boundary_type integer :: id_clock_forcing !< A CPU time clock @@ -275,7 +282,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.) + ustar=.true., press=.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) @@ -669,7 +676,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ real :: mass_eff ! effective mass of sea ice for rigidity [kg m-2] real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -710,6 +717,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) + if ( associated(IOB%ustk0) ) & + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -769,6 +779,19 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) enddo ; enddo endif + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers + do j=js,je; do i=is,ie + forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? + forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) + enddo ; enddo + call pass_vector(forces%ustk0,forces%vstk0, G%domain ) + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) + enddo; enddo + call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) + enddo ! Find the net mass source in the input forcing without other adjustments. if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 1f01845ae4..75b604a9d8 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -557,7 +557,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! For now, the waves are only updated on the thermodynamics steps, because that is where ! the wave intensities are actually used to drive mixing. At some point, the wave updates ! might also need to become a part of the ocean dynamics, according to B. Reichl. - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 12b12cf717..a8056129ff 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -606,6 +606,20 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%lrunoff = 0.0 Ice_ocean_boundary%frunoff = 0.0 + if (ocean_state%use_waves) then + Ice_ocean_boundary%num_stk_bands=ocean_state%Waves%NumBands + allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & + Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & + Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary% vstkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) + Ice_ocean_boundary%ustk0 = 0.0 + Ice_ocean_boundary%vstk0 = 0.0 + Ice_ocean_boundary%stk_wavenumbers = ocean_state%Waves%WaveNum_Cen + Ice_ocean_boundary%ustkb = 0.0 + Ice_ocean_boundary%vstkb = 0.0 + endif + ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -649,6 +663,17 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !These are not currently used and changing requires a nuopc dictionary change !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") + if (ocean_state%use_waves) then + if (Ice_ocean_boundary%num_stk_bands > 3) then + call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") + endif + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_1" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_1", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_2" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_2", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_3" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_3", "will provide") + endif !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index f1be8a3ea3..8aca45094f 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -73,6 +73,8 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, character(len=128) :: fldname real(ESMF_KIND_R8), allocatable :: taux(:,:) real(ESMF_KIND_R8), allocatable :: tauy(:,:) + real(ESMF_KIND_R8), allocatable :: stkx1(:,:),stkx2(:,:),stkx3(:,:) + real(ESMF_KIND_R8), allocatable :: stky1(:,:),stky2(:,:),stky3(:,:) character(len=*) , parameter :: subname = '(mom_import)' rc = ESMF_SUCCESS @@ -245,6 +247,56 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, isc, iec, jsc, jec, ice_ocean_boundary%mi, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! Partitioned Stokes Drift Components + !---- + if ( associated(ice_ocean_boundary%ustkb) ) then + allocate(stkx1(isc:iec,jsc:jec)) + allocate(stky1(isc:iec,jsc:jec)) + allocate(stkx2(isc:iec,jsc:jec)) + allocate(stky2(isc:iec,jsc:jec)) + allocate(stkx3(isc:iec,jsc:jec)) + allocate(stky3(isc:iec,jsc:jec)) + + call state_getimport(importState,'eastward_partitioned_stokes_drift_1' , isc, iec, jsc, jec, stkx1,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_1', isc, iec, jsc, jec, stky1,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'eastward_partitioned_stokes_drift_2' , isc, iec, jsc, jec, stkx2,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_2', isc, iec, jsc, jec, stky2,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'eastward_partitioned_stokes_drift_3' , isc, iec, jsc, jec, stkx3,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_3', isc, iec, jsc, jec, stky3,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rotate from true zonal/meridional to local coordinates + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%ustkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stkx1(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky1(i,j) + ice_ocean_boundary%vstkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stky1(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx1(i,j) + + ice_ocean_boundary%ustkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stkx2(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky2(i,j) + ice_ocean_boundary%vstkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stky2(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx2(i,j) + + ice_ocean_boundary%ustkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stkx3(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky3(i,j) + ice_ocean_boundary%vstkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stky3(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx3(i,j) + enddo + enddo + + deallocate(stkx1,stkx2,stkx3,stky1,stky2,stky3) + endif + end subroutine mom_import !> Maps outgoing ocean data to ESMF State diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 0245d9633d..6a50d3c03c 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -143,7 +143,7 @@ module MOM_ocean_model_nuopc integer :: nstep = 0 !< The number of calls to update_ocean. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: use_waves !< If true use wave coupling. + logical,public :: use_waves !< If true use wave coupling. logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. @@ -203,7 +203,7 @@ 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(wave_parameters_cs), pointer :: & + type(wave_parameters_cs), pointer, public :: & Waves !< A structure containing pointers to the surface wave fields type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure @@ -386,6 +386,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "If true, enables surface wave modules.", default=.false.) if (OS%use_waves) then call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) + call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",OS%Waves%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & + default=0.12566) else call MOM_wave_interface_init_lite(param_file) endif @@ -570,7 +573,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) if (OS%use_waves) then - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) endif if (OS%nstep==0) then diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 7f729e3c3e..7714793e42 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -181,9 +181,15 @@ module MOM_surface_forcing_nuopc !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model in [m3/s] + real, pointer, dimension(:,:) :: ustk0 => NULL() !< + real, pointer, dimension(:,:) :: vstk0 => NULL() !< + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of - !! named fields used for passive tracer fluxes. + !! namedfields used for passive tracer fluxes. integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of !! wind stresses. This flag may be set by the !! flux-exchange code, based on what the sea-ice @@ -619,7 +625,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: mass_eff !< effective mass of sea ice for rigidity (kg/m^2) integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -658,6 +664,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if ( (associated(IOB%area_berg) .and. (.not. associated(forces%area_berg))) .or. & (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) + if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -668,6 +675,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + if ( associated(IOB%ustkb) ) & + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + ! applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then forces%p_surf_SSH => forces%p_surf @@ -825,6 +835,24 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) endif ! endif for wind related fields + ! wave to ocean coupling + if ( associated(IOB%ustkb) ) then + + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers + do j=js,je; do i=is,ie + forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? + forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) + enddo ; enddo + call pass_vector(forces%ustk0,forces%vstk0, G%domain ) + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) + enddo; enddo + call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) + enddo + endif + ! sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then call pass_var(rigidity_at_h, G%Domain, halo=1) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3dd3af8fbf..699709722d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -230,6 +230,15 @@ module MOM_forcing_type !! ice needs to be accumulated, and the rigidity explicitly !! reset to zero at the driver level when appropriate. + real, pointer, dimension(:,:) :: & + ustk0 => NULL(), & + vstk0 => NULL() + real, pointer, dimension(:) :: & + stk_wavenumbers => NULL() + real, pointer, dimension(:,:,:) :: & + ustkb => NULL(), & + vstkb => NULL() + logical :: initialized = .false. !< This indicates whether the appropriate arrays have been initialized. end type mech_forcing @@ -2875,7 +2884,7 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic end subroutine allocate_forcing_type !> Conditionally allocate fields within the mechanical forcing type -subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg) +subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg, waves, num_stk_bands) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -2884,6 +2893,8 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg logical, optional, intent(in) :: shelf !< If present and true, allocate forces for ice-shelf logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields 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 ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -2910,6 +2921,18 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg call myAlloc(forces%area_berg,isd,ied,jsd,jed, iceberg) call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) + !These fields should only be allocated when waves are being passed through the coupler + call myAlloc(forces%ustk0,isd,ied,jsd,jed, waves) + call myAlloc(forces%vstk0,isd,ied,jsd,jed, waves) + if (present(waves)) then; if (waves) then; if (.not.associated(forces%ustkb)) then + if (.not.(present(num_stk_bands))) call MOM_error(FATAL,"Requested to initialize with waves, but no waves are present.") + allocate(forces%stk_wavenumbers(num_stk_bands)) ; forces%stk_wavenumbers (:) = 0.0 + allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) ; forces%ustkb(isd:ied,jsd:jed,:) = 0.0 + endif; endif; endif + if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then + allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands)) ; forces%vstkb(isd:ied,jsd:jed,:) = 0.0 + endif; endif; endif + end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 46aced3127..23c9c3a678 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -9,6 +9,7 @@ module MOM_wave_interface use MOM_domains, only : To_South, To_West, To_All use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : 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(/) @@ -68,6 +69,9 @@ module MOM_wave_interface !! approach. ! Surface Wave Dependent 1d/2d/3d vars + integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive + !! This needs to match the number of bands provided + !! via either coupling or file. real, allocatable, dimension(:), public :: & WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] real, allocatable, dimension(:), public :: & @@ -138,10 +142,6 @@ module MOM_wave_interface !! \todo Module variable! Move into a control structure. ! Options if WaveMethod is Surface Stokes Drift Bands (1) -integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive - !! This needs to match the number of bands provided - !! via either coupling or file. - !! \todo Module variable! Move into a control structure. integer, public :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers !! 1 - frequencies @@ -300,22 +300,34 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "Filename of surface Stokes drift input band data.", default="StkSpec.nc") case (COUPLER_STRING)! Reserved for coupling DataSource = Coupler + ! This is just to make something work, but it needs to be read from the wavemodel. + call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & + "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & + "This has to be consistent with the number of Stokes drift bands in WW3, "//& + "or the model will fail.",units='', default=1) + allocate( CS%WaveNum_Cen(CS%NumBands) ) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) + allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) + CS%WaveNum_Cen(:) = 0.0 + CS%STKx0(:,:,:) = 0.0 + CS%STKy0(:,:,:) = 0.0 + partitionmode = 0 case (INPUT_STRING)! A method to input the Stokes band (globally uniform) DataSource = Input - call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & + call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & "Prescribe number of wavenumber bands for Stokes drift. "// & "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & "STOKES_Y, there are no safety checks in the code.", & units='', default=1) - allocate( CS%WaveNum_Cen(1:NumBands) ) + allocate( CS%WaveNum_Cen(1:CS%NumBands) ) CS%WaveNum_Cen(:) = 0.0 - allocate( CS%PrescribedSurfStkX(1:NumBands)) + allocate( CS%PrescribedSurfStkX(1:CS%NumBands)) CS%PrescribedSurfStkX(:) = 0.0 - allocate( CS%PrescribedSurfStkY(1:NumBands)) + allocate( CS%PrescribedSurfStkY(1:CS%NumBands)) CS%PrescribedSurfStkY(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands)) CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands)) CS%STKy0(:,:,:) = 0.0 partitionmode=0 call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & @@ -433,13 +445,14 @@ subroutine MOM_wave_interface_init_lite(param_file) end subroutine MOM_wave_interface_init_lite !> Subroutine that handles updating of surface wave/Stokes drift related properties -subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS) +subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) 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 type(time_type), intent(in) :: Day !< Current model time type(time_type), intent(in) :: dt !< Timestep as a time-type + type(mech_forcing), intent(in) :: forces !< MOM_forcing_type ! Local variables integer :: ii, jj, kk, b type(time_type) :: Day_Center @@ -453,9 +466,29 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS) if (DataSource==DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) elseif (DataSource==Coupler) then - ! Reserve for coupler hooks + if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then + call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& + "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& + "ww3_grid.inp, and that your mod_def.ww3 is up to date.") + endif + + do b=1,CS%NumBands + CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) + !Interpolate from a grid to c grid + do II=G%iscB,G%iecB + do jj=G%jsc,G%jec + CS%STKx0(II,jj,b) = 0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + enddo + enddo + do ii=G%isc,G%iec + do JJ=G%jscB, G%jecB + CS%STKY0(ii,JJ,b) = 0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + enddo + enddo + call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) + enddo elseif (DataSource==Input) then - do b=1,NumBands + do b=1,CS%NumBands do II=G%isdB,G%iedB do jj=G%jsd,G%jed CS%STKx0(II,jj,b) = CS%PrescribedSurfStkX(b) @@ -485,13 +518,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. ! Local Variables - real :: Top, MidPoint, Bottom, one_cm + real :: Top, MidPoint, Bottom, one_cm, level_thick, min_level_thick_avg real :: DecayScale real :: CMN_FAC, WN, UStokes real :: La integer :: ii, jj, kk, b, iim1, jjm1 one_cm = 0.01*US%m_to_Z + min_level_thick_avg = 1.e-3*US%m_to_Z ! 1. If Test Profile Option is chosen ! Computing mid-point value from surface value and decay wavelength @@ -536,7 +570,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do jj = G%jsd,G%jed ! 1. First compute the surface Stokes drift ! by integrating over the partitionas. - do b = 1,NumBands + do b = 1,CS%NumBands if (PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & @@ -552,26 +586,40 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do kk = 1,G%ke Top = Bottom IIm1 = max(II-1,1) - 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)) - do b = 1,NumBands - if (PartitionMode==0) then + level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Bottom - 0.5*level_thick + Bottom = Bottom - level_thick + ! -> Stokes drift in thin layers not averaged. + if (level_thick>min_level_thick_avg) then + do b = 1,CS%NumBands + if (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))) - elseif (PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + elseif (PartitionMode==1) then + if (CS%StkLevelMode==0) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + elseif (CS%StkLevelMode==1) then + ! Use a numerical integration and then + ! divide by layer thickness + WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif endif - endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC - enddo + 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 + do b = 1,CS%NumBands + if (PartitionMode==0) then + CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) + elseif (PartitionMode==1) then + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + endif + CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + enddo + endif enddo enddo enddo @@ -579,7 +627,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do ii = G%isd,G%ied do JJ = G%jsdB,G%jedB ! Compute the surface values. - do b = 1,NumBands + do b = 1,CS%NumBands if (PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & @@ -595,27 +643,40 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do kk = 1,G%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)) - do b = 1,NumBands - if (PartitionMode==0) then + level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.5*level_thick + Bottom = Bottom - level_thick + ! -> Stokes drift in thin layers not averaged. + if (level_thick>min_level_thick_avg) then + do b = 1,CS%NumBands + if (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))) - elseif (PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + elseif (PartitionMode==1) then + if (CS%StkLevelMode==0) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + elseif (CS%StkLevelMode==1) then + ! Use a numerical integration and then + ! divide by layer thickness + WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif endif - endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC - enddo + 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 + do b = 1,CS%NumBands + if (PartitionMode==0) then + CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) + elseif (PartitionMode==1) then + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + endif + CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + enddo + endif enddo enddo enddo @@ -812,8 +873,8 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) trim(varread1)//",dim_name "//trim(dim_name(1))// & " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") endif - NUMBANDS = ID - do B = 1,NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo + CS%NUMBANDS = ID + do B = 1,CS%NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo elseif (PartitionMode==1) then rcode_fr = NF90_GET_VAR(ncid, dim_id(1), CS%Freq_Cen, start, counter) if (rcode_fr /= 0) then @@ -822,15 +883,15 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) trim(varread2)//",dim_name "//trim(dim_name(1))// & " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") endif - NUMBANDS = ID - do B = 1,NumBands + CS%NUMBANDS = ID + do B = 1,CS%NumBands CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) enddo endif endif - do b = 1,NumBands + do b = 1,CS%NumBands temp_x(:,:) = 0.0 temp_y(:,:) = 0.0 varname = ' ' @@ -904,9 +965,10 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [m s-1] logical :: ContinueLoop, USE_MA real, dimension(SZK_(G)) :: US_H, VS_H - real, dimension(NumBands) :: StkBand_X, StkBand_Y + real, allocatable :: StkBand_X(:), StkBand_Y(:) integer :: KK, BB + ! Compute averaging depth for Stokes drift (negative) Dpt_LASL = min(-0.1*US%m_to_Z, -LA_FracHBL*HBL) @@ -940,13 +1002,15 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) elseif (WaveMethod==SURFBANDS) then - do bb = 1,NumBands + allocate(StkBand_X(WAVES%NumBands), StkBand_Y(WAVES%NumBands)) + do bb = 1,WAVES%NumBands StkBand_X(bb) = 0.5*(WAVES%STKx0(I,j,bb)+WAVES%STKx0(I-1,j,bb)) StkBand_Y(bb) = 0.5*(WAVES%STKy0(i,J,bb)+WAVES%STKy0(i,J-1,bb)) enddo - call Get_SL_Average_Band(GV, Dpt_LASL, NumBands, WAVES%WaveNum_Cen, StkBand_X, LA_STKx ) - call Get_SL_Average_Band(GV, Dpt_LASL, NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) + call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_X, LA_STKx ) + call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + deallocate(StkBand_X, StkBand_Y) elseif (WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity do kk = 1,GV%ke From 92581e2be773af45feb45cc705a3f561bd5f7a17 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 11:07:25 -0600 Subject: [PATCH 012/212] Minor improvements in the bulk method --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 58fa8e6cc0..d164a1dfb1 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -166,7 +166,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 100. - hbl(4:6,:) = 50. + hbl(4:6,:) = 500. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) @@ -638,9 +638,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, !! interior [nondim] real :: a !< coefficient to be used in the linear transition to the !! interior [nondim] + + F_bulk = 0. + F_layer(:) = 0. if (hbl_L == 0. .or. hbl_R == 0.) then - F_bulk = 0. - F_layer(:) = 0. return endif @@ -662,7 +663,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, zeta_top_L, k_bot_L, zeta_bot_L) phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) @@ -670,12 +670,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. - if (boundary == SURFACE) then k_min = MIN(k_bot_L, k_bot_R) k_max = MAX(k_bot_L, k_bot_R) k_diff = (k_max - k_min) - if ((linear) .and. (k_diff .gt. 1)) then do k=1,k_min h_means(k) = harmonic_mean(h_L(k),h_R(k)) @@ -732,14 +730,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, enddo endif - if ( SUM(h_means) == 0. ) then + if ( SUM(h_means) == 0. .or. F_bulk == 0.) then return - ! Decompose the bulk flux onto the individual layers + ! Decompose the bulk flux onto the individual layers else ! Initialize remaining thickness inv_heff = 1./SUM(h_means) do k=1,nk - if (h_means(k) > 0.) then + if ((h_means(k) > 0.) .and. (phi_L(k) /= phi_R(k))) then hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac From 7299d8653603580bfe39143db453ed39d6222005 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 11:09:28 -0600 Subject: [PATCH 013/212] Fix bug when applying ND only in the interior When using the option to apply neutral diffusion only below the surface boundary layer we were using (1.-zeta). This is wrong. It should be just (zeta). --- src/tracer/MOM_neutral_diffusion.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 004c3ea8bc..d20a619026 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -294,7 +294,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! check if hbl needs to be extracted if (CS%interior_only) then hbl(:,:) = 100. - hbl(4:6,:) = 50. + hbl(4:6,:) = 500. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) @@ -425,7 +425,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & - k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) + k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -446,7 +446,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & - k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) + k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & From 09ad69505852d1e3545f3bb7f5b63711d81674ff Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 7 Jul 2020 15:41:25 -0600 Subject: [PATCH 014/212] Add option to apply linear decay at the base of hbl --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 32 +++++++++++++++---- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d164a1dfb1..52f2d1200a 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -473,7 +473,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot !< Total column thickness [m] + real :: htot !< Total column thickness [m] + real :: heff_tot !< Total effective column thickness in the transition layer [m] integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively @@ -532,12 +533,19 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo + ! heff_total + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - a = -1.0/k_bot_diff - do k = k_bot_min+1,k_bot_max-1, 1 - wgt = (a*(k-k_bot_min)) + 1.0 + a = -1.0/heff_tot + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + heff_tot = heff_tot + heff enddo else F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) @@ -619,6 +627,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] real :: htot ! Total column thickness [m] + real :: heff_tot !< Total effective column thickness in the transition layer [m] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively integer :: k_diff !< difference between k_max and k_min integer :: k_top_L, k_bot_L !< k-indices left @@ -678,11 +687,20 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, do k=1,k_min h_means(k) = harmonic_mean(h_L(k),h_R(k)) enddo + ! heff_total + heff_tot = 0.0 + do k = k_min+1,k_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo + + a = -1.0/heff_tot + heff_tot = 0.0 ! fluxes will decay linearly at base of hbl - a = -1.0/k_diff - do k = k_min+1,k_max-1, 1 - wgt = (a*(k-k_min)) + 1.0 + do k = k_min+1,k_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt + heff_tot = heff_tot + heff enddo else ! left hand side From a49954a73ce1297cf814b9cf1f88115ab7f94dcc Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 7 Jul 2020 16:14:02 -0600 Subject: [PATCH 015/212] comment calls to BLD schemes --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +++--- src/tracer/MOM_neutral_diffusion.F90 | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d6f1372f46..ec47d861ba 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -167,9 +167,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 100. - hbl(4:6,:) = 500. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + hbl(4:6,:) = 100. + !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) + !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) do m = 1,Reg%ntr diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index c6033bb891..a286122705 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -316,9 +316,9 @@ 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 hbl(:,:) = 100. - hbl(4:6,:) = 500. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + hbl(4:6,:) = 100. + !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) + !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 From cbcf3ec9b19c6e35ea836b1d5cf1bacebbdc414a Mon Sep 17 00:00:00 2001 From: jiandewang Date: Fri, 10 Jul 2020 23:34:22 -0400 Subject: [PATCH 016/212] bug fixing: (1) add missing halo in MOM_full_convection.F90 (2) remove wrong logic "not" in MOM.F90 at line 2669 --- src/core/MOM.F90 | 2 +- src/parameterizations/vertical/MOM_full_convection.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a044f95893..4c3d6bd250 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2666,7 +2666,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 (.not.query_initialized(CS%tv%frazil,"frazil",restart_CSp)) then + if (query_initialized(CS%tv%frazil,"frazil",restart_CSp)) then ! Test whether the dimensional rescaling has changed for heat content. if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 1783955d53..3be6628b14 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -408,7 +408,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - EOSdom(:) = EOS_domain(G%HI) + EOSdom(:) = EOS_domain(G%HI, halo) call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz From 7e1188c7221076acfabe877b6ca919eb42c7a07b Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 6 Aug 2020 16:57:53 -0400 Subject: [PATCH 017/212] add statediagnose feature (#31) --- config_src/nuopc_driver/mom_cap.F90 | 35 +++- config_src/nuopc_driver/mom_cap_methods.F90 | 183 +++++++++++++++++++- 2 files changed, 210 insertions(+), 8 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index a8056129ff..d49f370a47 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -26,7 +26,7 @@ module MOM_cap_mod 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_file_parser, only: get_param, log_version, param_file_type, close_param_file -use MOM_get_input, only: Get_MOM_Input, directories +use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var use MOM_error_handler, only: MOM_error, FATAL, is_root_pe use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type @@ -36,7 +36,7 @@ module MOM_cap_mod use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh use MOM_cap_time, only: AlarmInit -use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype +use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, state_diagnose #ifdef CESMCOUPLED use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit #endif @@ -124,7 +124,7 @@ module MOM_cap_mod integer :: fldsFrOcn_num = 0 type (fld_list_type) :: fldsFrOcn(fldsMax) -integer :: debug = 0 +integer :: dbug = 0 integer :: import_slice = 1 integer :: export_slice = 1 character(len=256) :: tmpstr @@ -273,6 +273,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) grid_attach_area call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value,*) dbug + end if + write(logmsg,'(i6)') dbug + call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) + scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -358,6 +366,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid => NULL() + type(directories) :: dirs type(time_type) :: Run_len !< length of experiment type(time_type) :: time0 !< Start time of coupled model's calendar. type(time_type) :: time_start !< The time at which to initialize the ocean model @@ -520,8 +529,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) restartfile = "" if (runtype == "initial") then - - restartfile = "n" + if (cesm_coupled) then + restartfile = "n" + else + call get_MOM_input(dirs=dirs) + restartfile = dirs%input_filename(1:1) + endif + call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfile), ESMF_LOGMSG_INFO) else if (runtype == "continue") then ! hybrid or branch or continuos runs @@ -821,7 +835,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) allocate(xb(ntiles),xe(ntiles),yb(ntiles),ye(ntiles),pe(ntiles)) 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 (debug > 0) then + if (dbug > 1) then do n = 1,ntiles 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) @@ -1431,6 +1445,11 @@ subroutine ModelAdvance(gcomp, rc) enddo endif + if (dbug > 0) then + call state_diagnose(importState,subname//':IS ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + !--------------- ! Get ocean grid !--------------- @@ -1459,6 +1478,10 @@ subroutine ModelAdvance(gcomp, rc) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if endif !--------------- diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 8aca45094f..0997fbc635 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -5,7 +5,7 @@ module MOM_cap_methods use ESMF, only: ESMF_TimeInterval, ESMF_TimeIntervalGet use ESMF, only: ESMF_State, ESMF_StateGet use ESMF, only: ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate -use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_Grid, ESMF_GridCreate +use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_MeshGet, ESMF_Grid, ESMF_GridCreate use ESMF, only: ESMF_DistGrid, ESMF_DistGridCreate use ESMF, only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE @@ -13,7 +13,8 @@ module MOM_cap_methods use ESMF, only: ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND use ESMF, only: ESMF_GEOMTYPE_FLAG, ESMF_GEOMTYPE_GRID, ESMF_GEOMTYPE_MESH use ESMF, only: ESMF_RC_VAL_OUTOFRANGE, ESMF_INDEX_DELOCAL, ESMF_MESHLOC_ELEMENT -use ESMF, only: ESMF_TYPEKIND_R8 +use ESMF, only: ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_COMPLETE +use ESMF, only: ESMF_FieldStatus_Flag, ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR use ESMF, only: operator(/=), operator(==) use MOM_ocean_model_nuopc, only: ocean_public_type, ocean_state_type use MOM_surface_forcing_nuopc, only: ice_ocean_boundary_type @@ -28,6 +29,7 @@ module MOM_cap_methods public :: mom_set_geomtype public :: mom_import public :: mom_export +public :: state_diagnose private :: State_getImport private :: State_setExport @@ -763,6 +765,183 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid end subroutine State_SetExport +subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + character(len=ESMF_MAXSTR) :: msgString + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + enddo + + deallocate(lfieldnamelist) + +end subroutine state_diagnose + +!=============================================================================== + +subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr1(:) + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + +end subroutine field_getfldptr + logical function chkerr(rc, line, file) integer, intent(in) :: rc integer, intent(in) :: line From 1fd53935dc8b11e4e70a9dc3e43d422a162f9a51 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 15:29:50 -0600 Subject: [PATCH 018/212] Fix bug in loop-indices when applying linear decay --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index ec47d861ba..d1dd6b5189 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -167,7 +167,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 100. - hbl(4:6,:) = 100. + hbl(4:6,:) = 500. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) @@ -532,19 +532,19 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L ! GMM, khtr_avg should be computed once khtr is 3D if ((linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl - do k = k_bot_min,1,-1 + do k = k_bot_min-1,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo ! heff_total heff_tot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 + do k = k_bot_min,k_bot_max, 1 heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) enddo a = -1.0/heff_tot heff_tot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 + do k = k_bot_min,k_bot_max, 1 heff = harmonic_mean(h_L(k), h_R(k)) wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt From 9957e55c6558599476f692ed28bc361c1be7c16c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 15:32:02 -0600 Subject: [PATCH 019/212] Fix bug in loop-indices when using discontinuous ND and interior_only --- src/tracer/MOM_neutral_diffusion.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index a286122705..3a335c82d4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -316,7 +316,7 @@ 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 hbl(:,:) = 100. - hbl(4:6,:) = 100. + hbl(4:6,:) = 500. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) @@ -434,7 +434,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) if (CS%interior_only) then if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. ! set values in the surface and bottom boundary layer to false. - do k = 1, k_bot(i,j)-1 + do k = 1, k_bot(i,j) CS%stable_cell(i,j,k) = .false. enddo endif From d8ae09f80e193a1d1ab94be4f03b1856aa31b668 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 4 Sep 2020 15:54:13 -0600 Subject: [PATCH 020/212] Rename lateral_boundary_diffusion_CS to lbd_CS --- src/tracer/MOM_tracer_hor_diff.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 02255d9424..89ab479903 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -23,7 +23,7 @@ module MOM_tracer_hor_diff 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 : lateral_boundary_diffusion_CS, lateral_boundary_diffusion_init +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 @@ -64,7 +64,7 @@ module MOM_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(lateral_boundary_diffusion_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for + type(lbd_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for !! lateral boundary mixing. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. From 2a80964973d7bed74ed91b274b54dfef8a8409fe Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 4 Sep 2020 15:55:06 -0600 Subject: [PATCH 021/212] First attempt to use remapping in LBD --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 182 ++++++++++-------- 1 file changed, 99 insertions(+), 83 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index dd2e015632..53770f4770 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -17,6 +17,7 @@ module MOM_lateral_boundary_diffusion use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme +use MOM_remapping, only : remapping_core_h use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -36,7 +37,7 @@ module MOM_lateral_boundary_diffusion #include !> Sets parameters for lateral boundary mixing module. -type, public :: lateral_boundary_diffusion_CS ; private +type, public :: lbd_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes !! 1. Along layer @@ -48,13 +49,14 @@ module MOM_lateral_boundary_diffusion !! Only valid when method = 2. 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, dimension(20) :: zgrid_top !< top vertical grid to remap the state before applying lateral diffusion + real, dimension(20) :: zgrid_bot !< bot vertical grid to remap the state before applying lateral diffusion 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 lateral_boundary_diffusion_CS +end type lbd_CS ! This include declares and sets the variable "version". #include "version_variable.h" @@ -70,7 +72,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab 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(lateral_boundary_diffusion_CS), pointer :: CS !< Lateral boundary mixing control structure + type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure ! local variables character(len=80) :: string ! Temporary strings @@ -118,6 +120,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) + CS%zgrid_top(:) = 25.0 call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& @@ -144,16 +147,19 @@ subroutine lateral_boundary_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) type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module + type(lbd_CS), pointer :: CS !< Control structure for this module ! Local variables + integer, parameter :: nk_z = SIZE(CS%zgrid_top) !< Number of layers in zgrid real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] + !real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] + real, dimension(SZIB_(G),SZJ_(G),nk_z) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] + !real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] + real, dimension(SZI_(G),SZJB_(G),nk_z) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport @@ -186,8 +192,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo ; enddo ! Diffusive fluxes in the i-direction - uFlx(:,:,:) = 0. - vFlx(:,:,:) = 0. + uFlx(:,:,:) = 0. ! z-space + vFlx(:,:,:) = 0. ! z-space uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. @@ -196,20 +202,20 @@ subroutine lateral_boundary_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, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + call fluxes_layer_method(SURFACE, GV%ke, nk_z, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & - uFlx(I,j,:), CS%linear) + uFlx(I,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, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + call fluxes_layer_method(SURFACE, GV%ke, nk_z, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & - vFlx(i,J,:), CS%linear) + vFlx(i,J,:), CS) endif enddo enddo @@ -437,35 +443,38 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method1 -subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & +subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & - F_layer, linear_decay) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers [nondim] - integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] - real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + F_layer, CS) + + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers in the native grid [nondim] + integer, intent(in ) :: nk_z !< Number of layers in the local z-grid [nondim] + integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] + 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 + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary !! layer (right) [H ~> m or kg m-2] - 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] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [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] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point - !! [H L2 conc ~> m3 conc] - logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + real, dimension(nk_z), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local + !! z-grid [H L2 conc ~> m3 conc] + type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer ! Local variables + real, dimension(nk_z) :: phi_L_local !< Tracer values (left) in the zgrid [conc] + real, dimension(nk_z) :: phi_R_local !< Tracer values (right) in the zgrid [conc] real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be @@ -476,84 +485,91 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] real :: htot !< Total column thickness [H ~> m or kg m-2] - real :: heff_tot !< Total effective column thickness in the transition layer [m] + !real :: heff_tot !< Total effective column thickness in the transition layer [m] integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively - integer :: k_top_L, k_bot_L !< k-indices left - integer :: k_top_R, k_bot_R !< k-indices right + integer :: k_top_L, k_bot_L !< k-indices left native grid + integer :: k_top_R, k_bot_R !< k-indices right native grid + integer :: k_top_zgrid_L, k_bot_zgrid_L !< k-indices left zgrid + integer :: k_top_zgrid_R, k_bot_zgrid_R !< k-indices right zgrid real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary - !! layer depth [nondim] + !! 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 [nondim] + !!layer depth in the native grid [nondim] + real :: zeta_top_zgrid_L, zeta_top_zgrid_R !< distance from the top of a layer to the boundary + !! layer depth in the zgrid [nondim] + real :: zeta_bot_zgrid_L, zeta_bot_zgrid_R !< distance from the bottom of a layer to the boundary + !!layer depth in the zgrid [nondim] real :: h_work_L, h_work_R !< dummy variables real :: hbl_min !< minimum BLD (left and right) [m] 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] - logical :: linear !< True if apply a linear transition F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif - linear = .false. - if (PRESENT(linear_decay)) then - linear = linear_decay - endif - - ! Calculate vertical indices containing the boundary layer + ! Calculate vertical indices containing the boundary layer in the native grid call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + ! Calculate vertical indices containing the boundary layer in zgrid_top + call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_L, k_top_zgrid_L, zeta_top_zgrid_L, k_bot_zgrid_L, zeta_bot_zgrid_L) + call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_R, k_top_zgrid_R, zeta_top_zgrid_R, k_bot_zgrid_R, zeta_bot_zgrid_R) + + call remapping_core_h(CS%remap_cs, nk, h_L, phi_L, nk_z, CS%zgrid_top, phi_L_local) + call remapping_core_h(CS%remap_cs, nk, h_R, phi_R, nk_z, CS%zgrid_top, phi_R_local) 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_min = MIN(k_bot_zgrid_L, k_bot_zgrid_R) + k_bot_max = MAX(k_bot_zgrid_L, k_bot_zgrid_R) k_bot_diff = (k_bot_max - k_bot_min) ! make sure left and right k indices span same range - if (k_bot_min .ne. k_bot_L) then - k_bot_L = k_bot_min - zeta_bot_L = 1.0 + if (k_bot_min .ne. k_bot_zgrid_L) then + k_bot_zgrid_L = k_bot_min + zeta_bot_zgrid_L = 1.0 endif - if (k_bot_min .ne. k_bot_R) then - k_bot_R= k_bot_min - zeta_bot_R = 1.0 + if (k_bot_min .ne. k_bot_zgrid_R) then + k_bot_zgrid_R= k_bot_min + zeta_bot_zgrid_R = 1.0 endif - h_work_L = (h_L(k_bot_L) * zeta_bot_L) - h_work_R = (h_R(k_bot_R) * zeta_bot_R) + h_work_L = (CS%zgrid_top(k_bot_zgrid_L) * zeta_bot_zgrid_L) + h_work_R = (CS%zgrid_top(k_bot_zgrid_R) * zeta_bot_zgrid_R) + + ! GMM, the following needs to be modified. We need to calculate ppoly0_E_L and ppoly0_coefs_L here... + !phi_L_avg = average_value_ppoly( nk_z, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) + !phi_R_avg = average_value_ppoly( nk_z, phi_R_local, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) + !heff = harmonic_mean(h_work_L, h_work_R) - phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) - phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) - heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - if ((linear) .and. (k_bot_diff .gt. 1)) then + if ((CS%linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + !heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) enddo - ! heff_total - heff_tot = 0.0 + htot = 0.0 do k = k_bot_min+1,k_bot_max, 1 - heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + htot = htot + CS%zgrid_top(k) enddo - a = -1.0/heff_tot - heff_tot = 0.0 + a = -1.0/htot + htot = 0.0 do k = k_bot_min+1,k_bot_max, 1 - heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt - heff_tot = heff_tot + heff + !heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(htot + (CS%zgrid_top(k) * 0.5))) + 1.0 + F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) * wgt + htot = htot + CS%zgrid_top(k) enddo else F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_bot_min-1,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + !heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) enddo endif endif @@ -1056,10 +1072,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-3./) ) + !call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-3./) ) ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' @@ -1075,10 +1091,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + !call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) test_name = 'Different hbl and different column thicknesses (linear profile right)' @@ -1094,10 +1110,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 2. ppoly0_E_R(2,1) = 2.; ppoly0_E_R(2,2) = 4. khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) + !call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From eb58a2e23242ec0c23dd645ac4e21eaab2a3d490 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 9 Sep 2020 09:41:54 -0400 Subject: [PATCH 022/212] add ocean lag option, make cap consistent (#33) * use flag to control lag startup * additional log msg cleanup * clarify restart_mode control --- config_src/nuopc_driver/mom_cap.F90 | 175 +++++++++--------- config_src/nuopc_driver/mom_cap_methods.F90 | 8 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 5 +- .../mom_surface_forcing_nuopc.F90 | 2 +- src/framework/MOM_restart.F90 | 4 +- 5 files changed, 103 insertions(+), 91 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index d49f370a47..67bae67f74 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,7 +72,7 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast -use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) @@ -134,6 +134,7 @@ module MOM_cap_mod integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. logical :: grid_attach_area = .false. +logical :: use_coldstart = .true. character(len=128) :: scalar_field_name = '' integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 @@ -148,7 +149,7 @@ module MOM_cap_mod logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_GRID #endif -character(len=8) :: restart_mode = 'cmeps' +character(len=8) :: restart_mode = 'alarms' contains @@ -338,6 +339,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif + use_coldstart = .true. + call NUOPC_CompAttributeGet(gcomp, name="use_coldstart", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_coldstart=(trim(value)=="true") + write(logmsg,*) use_coldstart + call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO) + end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -389,6 +398,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file + character(len=2048) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar !-------------------------------- @@ -420,6 +431,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + !TODO: next two lines not present in NCAR call fms_init(mpi_comm_mom) call constants_init call field_manager_init @@ -527,24 +539,24 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif - restartfile = "" + restartfile = ""; restartfiles = "" if (runtype == "initial") then if (cesm_coupled) then - restartfile = "n" + restartfiles = "n" else call get_MOM_input(dirs=dirs) - restartfile = dirs%input_filename(1:1) + restartfiles = dirs%input_filename(1:1) endif - call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfile), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfiles), ESMF_LOGMSG_INFO) else if (runtype == "continue") then ! hybrid or branch or continuos runs if (cesm_coupled) then call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (localPet == 0) then ! this hard coded for rpointer.ocn right now @@ -554,17 +566,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + 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', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) endif @@ -572,7 +595,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(restartfile)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) call ocean_model_init_sfc(ocean_state, ocean_public) @@ -1250,9 +1273,9 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1349,10 +1372,12 @@ subroutine ModelAdvance(gcomp, rc) integer :: writeunit integer :: localPet type(ESMF_VM) :: vm - integer :: n + integer :: n, i character(240) :: import_timestr, export_timestr character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + integer :: num_rest_files rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1390,7 +1415,7 @@ subroutine ModelAdvance(gcomp, rc) ! Apply ocean lag for startup runs: !--------------- - if (cesm_coupled) then + if (cesm_coupled .or. (.not.use_coldstart)) then if (trim(runtype) == "initial") then ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run @@ -1489,55 +1514,42 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! If restart alarm exists and is ringing - write restart file !--------------- - if (restart_mode == 'cmeps') then + if (restart_mode == 'alarms') then call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! turn off the alarm call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! determine restart filename call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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) + ! 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 open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) @@ -1547,9 +1559,20 @@ subroutine ModelAdvance(gcomp, rc) return endif write(writeunit,'(a)') trim(restartname)//'.nc' + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif close(writeunit) endif - else + else ! not cesm_coupled ! write the final restart without a timestamp if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then write(restartname,'(A)')"MOM.res" @@ -1557,17 +1580,17 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds endif - end if - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + endif if (is_root_pe()) then write(logunit,*) subname//' writing restart file ',trim(restartname) endif - endif - end if ! end of restart_mode is cmeps + endif + end if ! restart_mode !--------------- ! Write diagnostics @@ -1694,8 +1717,7 @@ subroutine ModelSetRunClock(gcomp, rc) else call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! If restart_n is set and non-zero, then restart_option must be available from config if (isPresent .and. isSet) then @@ -1704,8 +1726,7 @@ subroutine ModelSetRunClock(gcomp, rc) if(restart_n /= 0)then call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_option call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & @@ -1720,25 +1741,20 @@ subroutine ModelSetRunClock(gcomp, rc) ! not used in nems call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) endif else - ! restart_n is zero, restart_mode will be nems - restart_mode = 'nems' - call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) + ! restart_n is zero, restarts will be written at finalize only (no alarm control) + restart_mode = 'no_alarms' + call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) endif - else - ! restart_n is not set, restart_mode will be nems - restart_mode = 'nems' - call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) endif endif - if (restart_mode == 'cmeps') then + if (restart_mode == 'alarms') then call AlarmInit(mclock, & alarm = restart_alarm, & option = trim(restart_option), & @@ -1746,25 +1762,18 @@ subroutine ModelSetRunClock(gcomp, rc) opt_ymd = restart_ymd, & RefTime = mcurrTime, & alarmname = 'restart_alarm', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) end if ! create a 1-shot alarm at the driver stop time stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) @@ -1822,8 +1831,8 @@ subroutine ocean_model_finalize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return Time = esmf2fms_time(currTime) - ! Do not write a restart unless mode is nems - if (restart_mode == 'nems') then + ! Do not write a restart unless mode is no_alarms + if (restart_mode == 'no_alarms') then write_restart = .true. else write_restart = .false. diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 0997fbc635..1d51c1e6dd 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -735,7 +735,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid do j = jsc, jec jg = j + ocean_grid%jsc - jsc do i = isc, iec - ig = i + ocean_grid%isc - isc + ig = i + ocean_grid%isc - isc n = n+1 dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo @@ -877,11 +877,11 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (status /= ESMF_FIELDSTATUS_COMPLETE) then lrank = 0 if (labort) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) rc = ESMF_FAILURE return else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) endif else @@ -901,7 +901,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (nnodes == 0 .and. nelements == 0) lrank = 0 else call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO, rc=rc) + ESMF_LOGMSG_INFO) rc = ESMF_FAILURE return endif ! geomtype diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 22fc90d0c1..2616d99e75 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -671,7 +671,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state being saved to a restart file character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be @@ -679,6 +679,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -690,7 +691,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (present(restartname)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + OS%restart_CSp, 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 diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 9f207c4a63..3516ad3803 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -191,7 +191,7 @@ module MOM_surface_forcing_nuopc integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of - !! namedfields used for passive tracer fluxes. + !! named fields used for passive tracer fluxes. integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of !! wind stresses. This flag may be set by the !! flux-exchange code, based on what the sea-ice diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..ca2e37afb9 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -849,7 +849,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name !> save_restart saves all registered variables to restart files. -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) 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 @@ -860,6 +860,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !! 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 ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that @@ -1056,6 +1057,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) num_files = num_files+1 enddo + if (present(num_rest_files)) num_rest_files = num_files end subroutine save_restart !> restore_state reads the model state from previously generated files. All From 5c56268ea2365da0a5eed498b875f7aa656a3249 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 21 Sep 2020 18:13:44 -0600 Subject: [PATCH 023/212] Adding options to specify dz to apply LBD @ top Valid options are: * PARAM - use the vector-parameter LBD_DZ_TOP * UNIFORM[:N] - uniformly distributed * FILE:string - read from a file --- src/ALE/MOM_regridding.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 205 +++++++++++++----- 2 files changed, 151 insertions(+), 56 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index ed6e66e0ae..0d607f55ed 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -140,7 +140,7 @@ module MOM_regridding public getCoordinateUnits, getCoordinateShortName, getStaticThickness public DEFAULT_COORDINATE_MODE public get_zlike_CS, get_sigma_CS, get_rho_CS - +public check_grid_def !> Documentation for coordinate options character(len=*), parameter, public :: regriddingCoordinateModeDoc = & " LAYER - Isopycnal or stacked shallow water layers\n"//& diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index aea70cae74..b65285b57f 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -11,19 +11,22 @@ module MOM_lateral_boundary_diffusion use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field 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, log_param use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_io, only : file_exists, field_size, MOM_read_data, slasher, field_exists use MOM_grid, only : ocean_grid_type use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_remapping, only : remapping_core_h +use MOM_regridding, only : check_grid_def 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_string_functions, only : extract_integer, extract_real, extractWord use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -43,14 +46,15 @@ module MOM_lateral_boundary_diffusion !! 1. Along layer !! 2. Bulk-layer approach (not recommended) integer :: deg !< Degree of polynomial reconstruction + integer :: nk !< Number of layers in dz_top integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP logical :: limiter !< Controls wether a flux limiter is applied. !! Only valid when method = 2. 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, dimension(500) :: zgrid_top !< top vertical grid to remap the state before applying lateral diffusion - real, dimension(500) :: zgrid_bot !< bot vertical grid to remap the state before applying lateral diffusion + real, dimension(:), allocatable :: dz_top !< top vertical grid to remap the state before applying lateral diffusion + real, dimension(:), allocatable :: dz_bot !< bot vertical grid to remap the state before applying lateral diffusion 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 @@ -75,9 +79,17 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure ! local variables - character(len=80) :: string ! Temporary strings - logical :: boundary_extrap - + character(len=80) :: string, varName ! Temporary strings + character(len=200) :: inputdir, fileName ! Temporary strings + character(len=320) :: message ! Temporary strings + character(len=12) :: expected_units ! Temporary strings + integer :: ke, nk ! Number of levels in the LBD and native grids, respectively + logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code + logical :: ierr + real :: tmpReal + integer :: nzf(4) + real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other + ! units depending on the coordinate if (ASSOCIATED(CS)) then call MOM_error(FATAL, "lateral_boundary_diffusion_init called with associated control structure.") return @@ -121,8 +133,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) - CS%zgrid_top(:) = 1.0 - CS%zgrid_bot(:) = 1.0 + CS%dz_bot(:) = 1.0 call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& @@ -130,7 +141,93 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - + ! set dz_top + call get_param(param_file, mdl, "LBD_DIAG_COORD_TOP", string, & + "Determines how to specify the vertical resolution "//& + "to apply lateral diffusion near the surface. Valid options are:\n"//& + " PARAM - use the vector-parameter LBD_DZ_TOP \n"//& + " UNIFORM[:N] - uniformly distributed\n"//& + " FILE:string - read from a file. The string specifies\n"//& + " the filename and variable name, separated\n"//& + " by a comma or space, e.g. FILE:lev.nc,dz\n"//& + " or FILE:lev.nc,interfaces=zw\n",& + default="UNIFORM:500,500") + message = "The distribution of vertical resolution used to \n"//& + "apply lateral diffusion near boundaries." + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "NK", nk, & + "The number of model layers.", units="nondim", fail_if_missing=.true., & + do_not_log=.true.) + if (index(trim(string),'UNIFORM')==1) then + call get_param(param_file, "MOM", "MAXIMUM_DEPTH", tmpReal, & + "The maximum depth of the ocean.", units="m", default=4000.0, do_not_log=.true.) + if (len_trim(string)==7) then + ke = nk ! Use model nk by default + elseif (index(trim(string),'UNIFORM:')==1 .and. len_trim(string)>8) then + ! Format is "UNIFORM:N" or "UNIFORM:N,MAX_DEPTH" + ke = extract_integer(string(9:len_trim(string)),'',1) + tmpReal = extract_real(string(9:len_trim(string)),',',2,missing_value=tmpReal) + else + call MOM_error(FATAL,trim(mdl)//', lateral_boundary_diffusion_init: '// & + 'Unable to interpret "'//trim(string)//'".') + endif + allocate(CS%dz_top(ke)) + CS%dz_top(:) = tmpReal / real(ke) + call log_param(param_file, mdl, "!LBD_DZ_TOP", CS%dz_top, & + trim(message), units='m') + elseif (trim(string)=='PARAM') then + ke = nk ! Use model nk by default + allocate(CS%dz_top(ke)) + call get_param(param_file, mdl, 'LBD_DZ_TOP', CS%dz_top, & + trim(message), units='m', fail_if_missing=.true.) + elseif (index(trim(string),'FILE:')==1) then + ! FILE:filename,var_name is assumed to be reading level thickness variables + ! FILE:filename,interfaces=var_name reads positions + if (string(6:6)=='.' .or. string(6:6)=='/') then + ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path + fileName = trim( extractWord(trim(string(6:80)), 1) ) + else + ! Otherwise assume we should look for the file in INPUTDIR + fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + endif + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + + varName = trim( extractWord(trim(string(6:)), 2) ) + if (len_trim(varName)==0) then + if (field_exists(fileName,'dz')) then; varName = 'dz' + else ; call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & + "Coordinate variable (dz) not specified and none could be guessed.") + endif + endif + expected_units = 'meters' + if (index(trim(varName),'interfaces=')==1) then + varName=trim(varName(12:)) + call check_grid_def(filename, varName, expected_units, message, ierr) + if (ierr) call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "//& + "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) + call field_size(trim(fileName), trim(varName), nzf) + ke = nzf(1)-1 + allocate(CS%dz_top(ke)) + allocate(z_max(ke+1)) + call MOM_read_data(trim(fileName), trim(varName), z_max) + CS%dz_top(:) = abs(z_max(1:ke) - z_max(2:ke+1)) + deallocate(z_max) + else + ! Assume reading resolution + call field_size(trim(fileName), trim(varName), nzf) + ke = nzf(1) + allocate(CS%dz_top(ke)) + call MOM_read_data(trim(fileName), trim(varName), CS%dz_top) + endif + call log_param(param_file, mdl, "!LBD_DZ_TOP", CS%dz_top, & + trim(message), units='m') + else + call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & + "Unrecognized coordinate configuration"//trim(string)) + endif + CS%nk = ke end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. @@ -152,21 +249,20 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(lbd_CS), pointer :: CS !< Control structure for this module ! Local variables - integer, parameter :: nk_z = SIZE(CS%zgrid_top) !< Number of layers in zgrid real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) !real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] - real, dimension(SZIB_(G),SZJ_(G),nk_z) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] + real, dimension(SZIB_(G),SZJ_(G),CS%nk) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer !real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] - real, dimension(SZI_(G),SZJB_(G),nk_z) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] + real, dimension(SZI_(G),SZJB_(G),CS%nk) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diag in the zgrid - real, dimension(SZI_(G),SZJ_(G),nk_z) :: tracer_z !< Tracer in the zgrid + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z !< Tracer in the zgrid 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 !type(tracer_type) :: tracer_old !< Local tracer copy, @@ -198,8 +294,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! remap tracer to zgrid do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - - call remapping_core_h(CS%remap_cs, G%ke, h(i,j,:), tracer%t(i,j,:), nk_z, CS%zgrid_top(:), tracer_z(i,j,:)) + call remapping_core_h(CS%remap_cs, G%ke, h(i,j,:), tracer%t(i,j,:), CS%nk, CS%dz_top(:), tracer_z(i,j,:)) !call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & ! ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo @@ -215,11 +310,11 @@ subroutine lateral_boundary_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, GV%ke, nk_z, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + !call fluxes_layer_method(SURFACE, GV%ke, CS%nk, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & ! G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & ! ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & ! uFlx(I,j,:), CS) - call fluxes_layer_method1(SURFACE, nk_z, hbl(I,j), hbl(I+1,j), & + call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & remap_method, Coef_x(I,j), uFlx(I,j,:), CS) endif @@ -228,11 +323,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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, nk_z, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + !call fluxes_layer_method(SURFACE, GV%ke, CS%nk, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & ! G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & ! ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & ! vFlx(i,J,:), CS) - call fluxes_layer_method1(SURFACE, nk_z, hbl(i,J), hbl(i,J+1), & + call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & remap_method, Coef_y(i,J), vFlx(i,J,:), CS) endif @@ -269,12 +364,12 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif ! Update the tracer fluxes - do k=1,nk_z ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,CS%nk ; 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)) tracer_z(i,j,k) = tracer_z(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)/( CS%zgrid_top(k) + GV%H_subroundoff)) + (G%IareaT(i,j)/( CS%dz_top(k) + GV%H_subroundoff)) endif @@ -282,7 +377,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! remap tracer back to native grid do j=G%jsc,G%jec ; do i=G%isc,G%iec - call remapping_core_h(CS%remap_cs, nk_z, CS%zgrid_top, tracer_z(i,j,:), G%ke, h(i,j,:),tracer%t(i,j,:)) + call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, tracer_z(i,j,:), G%ke, h(i,j,:),tracer%t(i,j,:)) enddo ; enddo if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then @@ -471,23 +566,23 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method1 -subroutine fluxes_layer_method1(boundary, nk_z, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & +subroutine fluxes_layer_method1(boundary, nk, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & method, khtr_u, F_layer, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk_z !< Number of layers in the local z-grid [nondim] + integer, intent(in ) :: nk !< Number of layers in the local z-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, 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] - real, dimension(nk_z), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk_z), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] - real, dimension(nk_z), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local !! z-grid [H L2 conc ~> m3 conc] type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer @@ -521,9 +616,9 @@ subroutine fluxes_layer_method1(boundary, nk_z, hbl_L, hbl_R, area_L, area_R, ph return endif - ! Calculate vertical indices containing the boundary layer in zgrid_top - call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, nk, CS%dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, CS%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) @@ -540,12 +635,12 @@ subroutine fluxes_layer_method1(boundary, nk_z, hbl_L, hbl_R, area_L, area_R, ph zeta_bot_R = 1.0 endif - h_work_L = (CS%zgrid_top(k_bot_L) * zeta_bot_L) - h_work_R = (CS%zgrid_top(k_bot_R) * zeta_bot_R) + h_work_L = (CS%dz_top(k_bot_L) * zeta_bot_L) + h_work_R = (CS%dz_top(k_bot_R) * zeta_bot_R) ! GMM, the following needs to be modified. We need to calculate ppoly0_E_L and ppoly0_coefs_L here... - !phi_L_avg = average_value_ppoly( nk_z, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) - !phi_R_avg = average_value_ppoly( nk_z, phi_R_local, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) + !phi_L_avg = average_value_ppoly( nk, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) + !phi_R_avg = average_value_ppoly( nk, phi_R_local, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) !heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer @@ -554,26 +649,26 @@ subroutine fluxes_layer_method1(boundary, nk_z, hbl_L, hbl_R, area_L, area_R, ph ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) enddo htot = 0.0 do k = k_bot_min+1,k_bot_max, 1 - htot = htot + CS%zgrid_top(k) + htot = htot + CS%dz_top(k) enddo a = -1.0/htot htot = 0.0 do k = k_bot_min,k_bot_max, 1 !heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(htot + (CS%zgrid_top(k) * 0.5))) + 1.0 - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) * wgt - htot = htot + CS%zgrid_top(k) + wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + htot = htot + CS%dz_top(k) enddo else !!F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_bot_min-1,1,-1 !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) enddo endif endif @@ -591,8 +686,8 @@ subroutine fluxes_layer_method1(boundary, nk_z, hbl_L, hbl_R, area_L, area_R, ph ! zeta_top_R = 1.0 ! endif ! -! h_work_L = (CS%zgrid_bot(k_top_L) * zeta_top_L) -! h_work_R = (CS%zgrid_bot(k_top_R) * zeta_top_R) +! h_work_L = (CS%dz_bot(k_top_L) * zeta_top_L) +! h_work_R = (CS%dz_bot(k_top_R) * zeta_top_R) ! ! phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, 1.0-zeta_top_L, 1.0) ! phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) @@ -682,12 +777,12 @@ subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, ! Calculate vertical indices containing the boundary layer in the zgrid call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate vertical indices containing the boundary layer in zgrid_top - call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_L, k_top_zgrid_L, zeta_top_zgrid_L, k_bot_zgrid_L, zeta_bot_zgrid_L) - call boundary_k_range(boundary, nk_z, CS%zgrid_top, hbl_R, k_top_zgrid_R, zeta_top_zgrid_R, k_bot_zgrid_R, zeta_bot_zgrid_R) + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, nk_z, CS%dz_top, hbl_L, k_top_zgrid_L, zeta_top_zgrid_L, k_bot_zgrid_L, zeta_bot_zgrid_L) + call boundary_k_range(boundary, nk_z, CS%dz_top, hbl_R, k_top_zgrid_R, zeta_top_zgrid_R, k_bot_zgrid_R, zeta_bot_zgrid_R) - call remapping_core_h(CS%remap_cs, nk, h_L, phi_L, nk_z, CS%zgrid_top, phi_L_local) - call remapping_core_h(CS%remap_cs, nk, h_R, phi_R, nk_z, CS%zgrid_top, phi_R_local) + call remapping_core_h(CS%remap_cs, nk, h_L, phi_L, nk_z, CS%dz_top, phi_L_local) + call remapping_core_h(CS%remap_cs, nk, h_R, phi_R, nk_z, CS%dz_top, phi_R_local) if (boundary == SURFACE) then k_bot_min = MIN(k_bot_zgrid_L, k_bot_zgrid_R) @@ -704,8 +799,8 @@ subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, zeta_bot_zgrid_R = 1.0 endif - h_work_L = (CS%zgrid_top(k_bot_zgrid_L) * zeta_bot_zgrid_L) - h_work_R = (CS%zgrid_top(k_bot_zgrid_R) * zeta_bot_zgrid_R) + h_work_L = (CS%dz_top(k_bot_zgrid_L) * zeta_bot_zgrid_L) + h_work_R = (CS%dz_top(k_bot_zgrid_R) * zeta_bot_zgrid_R) ! GMM, the following needs to be modified. We need to calculate ppoly0_E_L and ppoly0_coefs_L here... !phi_L_avg = average_value_ppoly( nk_z, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) @@ -718,26 +813,26 @@ subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) enddo htot = 0.0 do k = k_bot_min+1,k_bot_max, 1 - htot = htot + CS%zgrid_top(k) + htot = htot + CS%dz_top(k) enddo a = -1.0/htot htot = 0.0 do k = k_bot_min,k_bot_max, 1 !heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(htot + (CS%zgrid_top(k) * 0.5))) + 1.0 - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) * wgt - htot = htot + CS%zgrid_top(k) + wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) * wgt + htot = htot + CS%dz_top(k) enddo else F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_bot_min-1,1,-1 !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%zgrid_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) + F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) enddo endif endif From 1849bccd493965be09a4b9b9fd558cd663b5275c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 23 Sep 2020 15:43:15 -0600 Subject: [PATCH 024/212] Adding option to output u^2, v^2 and u*v --- src/diagnostics/MOM_diagnostics.F90 | 36 ++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 82be08100e..6a66cce515 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -106,7 +106,8 @@ module MOM_diagnostics KE_dia => NULL() !< KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3] !>@{ Diagnostic IDs - integer :: id_u = -1, id_v = -1, id_h = -1 + integer :: id_u = -1, id_v = -1, id_h = -1 + integer :: id_usq = -1, id_vsq = -1, id_uv = -1 integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 integer :: id_col_ht = -1, id_dh_dt = -1 @@ -223,6 +224,10 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! calculating interface heights [H ~> m or kg m-2]. ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: usq ! squared eastward velocity [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vsq ! squared northward velocity [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: uv ! u x v at h-points [L2 T-2 ~> m2 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, nkmb @@ -289,6 +294,28 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_h > 0) call post_data(CS%id_h, h, CS%diag) + if (CS%id_usq > 0) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + usq(I,j,k) = u(I,j,k) * u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_usq, usq, CS%diag) + endif + + if (CS%id_vsq > 0) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vsq(i,J,k) = v(i,J,k) * v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_usq, usq, CS%diag) + endif + + if (CS%id_uv > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + uv(i,j,k) = (0.5*(u(I-1,j,k) + u(I,j,k))) * & + (0.5*(v(i,J-1,k) + v(i,J,k))) + enddo ; enddo ; enddo + call post_data(CS%id_uv, uv, CS%diag) + endif + if (associated(CS%e)) then call find_eta(h, tv, G, GV, US, CS%e, eta_bt) if (CS%id_e > 0) call post_data(CS%id_e, CS%e, CS%diag) @@ -1577,6 +1604,13 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 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, & + '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, & + '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', 'm2 s-2', & + conversion=US%L_T_to_m_s**2) CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & 'Layer Thickness', thickness_units, v_extensive=.true., conversion=convert_H) From e0db9abcb2129cdf4a2fe402bc4a13686505fae8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 24 Sep 2020 09:48:52 -0600 Subject: [PATCH 025/212] Fix typo when posting vsq --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 6a66cce515..819131e51d 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -305,7 +305,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie vsq(i,J,k) = v(i,J,k) * v(i,J,k) enddo ; enddo ; enddo - call post_data(CS%id_usq, usq, CS%diag) + call post_data(CS%id_vsq, vsq, CS%diag) endif if (CS%id_uv > 0) then From 593ebfc1dc17c72c24c912368afcd950c93d279a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 29 Sep 2020 11:16:29 -0600 Subject: [PATCH 026/212] Delete fluxes_bulk_method --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 469 +++--------------- 1 file changed, 82 insertions(+), 387 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index b65285b57f..f218f21798 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -41,16 +41,10 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lbd_CS ; private - integer :: method !< Determine which of the three methods calculate - !! and apply near boundary layer fluxes - !! 1. Along layer - !! 2. Bulk-layer approach (not recommended) integer :: deg !< Degree of polynomial reconstruction integer :: nk !< Number of layers in dz_top integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP - logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 2. 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, dimension(:), allocatable :: dz_top !< top vertical grid to remap the state before applying lateral diffusion @@ -118,22 +112,12 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! endif ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & - "Determine how to apply boundary lateral diffusion of tracers: \n"//& - "1. Along layer approach \n"//& - "2. Bulk layer approach (this option is not recommended)", default=1) - if (CS%method == 2) then - call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & - "If True, apply a flux limiter in the LBD. This is only available \n"//& - "when LATERAL_BOUNDARY_METHOD=2.", default=.false.) - endif 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, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) - CS%dz_bot(:) = 1.0 call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& @@ -228,13 +212,15 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "Unrecognized coordinate configuration"//trim(string)) endif CS%nk = ke + ! TODO: set dz_bot + CS%dz_bot(:) = 1.0 end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. !! Two different methods are available: -!! Method 1: lower order representation, calculate fluxes from bulk layer integrated quantities. -!! Method 2: more straight forward, diffusion is applied layer by layer using only information +!! Method 1: more straight forward, diffusion is applied layer by layer using only information !! from neighboring cells. +!! Method 2: lower order representation, calculate fluxes from bulk layer integrated quantities. 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 @@ -265,17 +251,17 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z !< Tracer in the zgrid 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 - !type(tracer_type) :: tracer_old !< Local tracer copy, - !! only used to compute tendencies. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: t_old !< local copy of the initial tracer concentration, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, !! only used to compute tendencies. + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z_old!< Copy of the initial tracer concentration in z-space + integer :: remap_method !< Reconstruction method integer :: i,j,k,m !< indices to loop over real :: Idt !< inverse of the time step [s-1] Idt = 1./dt hbl(:,:) = 100. - hbl(4:6,:) = 500. + hbl(4:6,:) = 100. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) @@ -283,13 +269,13 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do m = 1,Reg%ntr tracer => Reg%tr(m) tracer_z(:,:,:) = 0.0 + tracer_z_old(:,:,:) = 0.0 ! for diagnostics if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then tendency(:,:,:) = 0.0 - !tracer_old = tracer + tracer_old(:,:,:) = 0.0 ! copy initial tracer state so that the tendency can be computed - t_old(:,:,:) = tracer%t(:,:,:) - !tracer_old%t => t_old + tracer_old(:,:,:) = tracer%t(:,:,:) endif ! remap tracer to zgrid @@ -299,69 +285,39 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo - ! Diffusive fluxes in the i-direction + ! Diffusive fluxes in the i- and j-direction uFlx(:,:,:) = 0. ! z-space vFlx(:,:,:) = 0. ! z-space uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. - ! Method #1 (layer by layer) - if (CS%method == 1) then - 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, GV%ke, CS%nk, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - ! G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ! ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & - ! uFlx(I,j,:), CS) - call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & - remap_method, Coef_x(I,j), uFlx(I,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, CS%nk, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - ! G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ! ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & - ! vFlx(i,J,:), CS) - call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & - remap_method, Coef_y(i,J), vFlx(i,J,:), CS) - endif - enddo - enddo - - ! Method #2 (bulk approach) - elseif (CS%method == 2) then - do j=G%jsc,G%jec - do i=G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & - ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & - CS%linear) - endif - enddo + ! 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, GV%ke, CS%nk, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + ! G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ! ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + ! uFlx(I,j,:), CS) + call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & + remap_method, Coef_x(I,j), uFlx(I,j,:), CS) + endif enddo - do J=G%jsc-1,G%jec - do i=G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & - ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & - CS%linear) - 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, CS%nk, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + ! G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ! ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + ! vFlx(i,J,:), CS) + call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & + remap_method, Coef_y(i,J), vFlx(i,J,:), CS) + endif enddo - ! Post tracer bulk diags - if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) - if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) - endif + enddo ! Update the tracer fluxes do k=1,CS%nk ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -370,19 +326,21 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! (G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) tracer_z(i,j,k) = tracer_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) - - + ! difference between before/after diffusion in the zgrid + tendency_z(i,j,k) = tracer_z(i,j,k) - tracer_z_old(i,j,k) endif enddo ; enddo ; enddo - ! remap tracer back to native grid + ! remap tracer "change" back to native grid do j=G%jsc,G%jec ; do i=G%isc,G%iec - call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, tracer_z(i,j,:), G%ke, h(i,j,:),tracer%t(i,j,:)) + tracer_1d(:) = 0.0 + call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, tendency_z(i,j,:), G%ke, h(i,j,:), tracer_1d(:)) + tracer%t(i,j,:) = tracer%t(i,j,:) + tracer_1d(:) enddo ; enddo if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then - do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - tendency(i,j,k) = (tracer%t(i,j,k)-t_old(i,j,k)) * Idt + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + tendency(i,j,k) = (tracer%t(i,j,k)-tracer_old(i,j,k)) * Idt enddo ; enddo ; enddo endif @@ -435,58 +393,6 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) end subroutine lateral_boundary_diffusion -!< Calculate bulk layer value of a scalar quantity as the thickness weighted average -real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & - zeta_bot) - integer :: boundary !< SURFACE or BOTTOM [nondim] - integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] - real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] - real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use - - integer :: k_top !< Index of the first layer within the boundary - real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer - !! (0 if none, 1. if all). For the surface, this is always 0. because - !! integration starts at the surface [nondim] - integer :: k_bot !< Index of the last layer within the boundary - real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer - !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. - !! because integration starts at the bottom [nondim] - ! Local variables - real :: htot !< Running sum of the thicknesses (top to bottom) - integer :: k !< k indice - - - htot = 0. - bulk_average = 0. - if (hblt == 0.) return - if (boundary == SURFACE) then - htot = (h(k_bot) * zeta_bot) - bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot - do k = k_bot-1,1,-1 - bulk_average = bulk_average + phi(k)*h(k) - htot = htot + h(k) - enddo - elseif (boundary == BOTTOM) then - htot = (h(k_top) * zeta_top) - ! (note 1-zeta_top because zeta_top is the fraction of the layer) - bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, (1.-zeta_top), 1.) * htot - do k = k_top+1,nk - bulk_average = bulk_average + phi(k)*h(k) - htot = htot + h(k) - enddo - else - call MOM_error(FATAL, "bulk_average: a valid boundary type must be provided.") - endif - - bulk_average = bulk_average / hBLT - -end function bulk_average - !> Calculate the harmonic mean of two quantities !! See \ref section_harmonic_mean. real function harmonic_mean(h1,h2) @@ -868,217 +774,6 @@ subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, end subroutine fluxes_layer_method -!> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' -!! See \ref section_method2 -subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & - linear_decay) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers [nondim] - integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] - 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 (left) [H ~> m or kg m-2] - 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] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t - !! at a velocity point [L2 ~> m2] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux - !! [H L2 conc ~> m3 conc] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point - !! [H L2 conc ~> m3 conc] - logical, optional, intent(in ) :: F_limit !< If True, apply a limiter - logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of - !! the boundary layer - - ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] - !! This is just to remind developers that khtr_avg should be - !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] - real :: heff_tot !< Total effective column thickness in the transition layer [m] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses - !! [H-1 ~> m-1 or m2 kg-1] - real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] - real :: htot ! Total column thickness [H ~> m or kg m-2] - integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively - integer :: k_diff !< difference between k_max and k_min - integer :: k_top_L, k_bot_L !< k-indices left - integer :: k_top_R, k_bot_R !< k-indices right - real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the - !! boundary layer [nondim] - real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the - !! boundary layer [nondim] - real :: h_work_L, h_work_R !< dummy variables - real :: F_max !< The maximum amount of flux that can leave a - !! cell [m^3 conc] - logical :: limiter !< True if flux limiter should be applied - logical :: linear !< True if apply a linear transition - real :: hfrac !< Layer fraction wrt sum of all layers [nondim] - real :: dphi !< tracer gradient [conc m^-3] - 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] - - F_bulk = 0. - F_layer(:) = 0. - if (hbl_L == 0. .or. hbl_R == 0.) then - return - endif - - limiter = .false. - if (PRESENT(F_limit)) then - limiter = F_limit - endif - linear = .false. - if (PRESENT(linear_decay)) then - linear = linear_decay - endif - - ! Calculate vertical indices containing the boundary layer - call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - - ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, & - zeta_top_L, k_bot_L, zeta_bot_L) - phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & - zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities - ! GMM, khtr_avg should be computed once khtr is 3D - heff = harmonic_mean(hbl_L, hbl_R) - F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) - ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated - ! above, but is used as a way to decompose the fluxes onto the individual layers - h_means(:) = 0. - if (boundary == SURFACE) then - k_min = MIN(k_bot_L, k_bot_R) - k_max = MAX(k_bot_L, k_bot_R) - k_diff = (k_max - k_min) - if ((linear) .and. (k_diff .gt. 1)) then - do k=1,k_min - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - ! heff_total - heff_tot = 0.0 - do k = k_min+1,k_max, 1 - heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) - enddo - - a = -1.0/heff_tot - heff_tot = 0.0 - ! fluxes will decay linearly at base of hbl - do k = k_min+1,k_max, 1 - heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 - h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt - heff_tot = heff_tot + heff - enddo - else - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L - else - h_work_L = h_L(k_min) - endif - - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif - - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - - do k=1,k_min-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - endif - - elseif (boundary == BOTTOM) then - !TODO, GMM linear decay is not implemented here - k_max = MAX(k_top_L, k_top_R) - ! left hand side - if (k_top_L == k_max) then - h_work_L = h_L(k_max) * zeta_top_L - else - h_work_L = h_L(k_max) - endif - - ! right hand side - if (k_top_R == k_max) then - h_work_R = h_R(k_max) * zeta_top_R - else - h_work_R = h_R(k_max) - endif - - h_means(k_max) = harmonic_mean(h_work_L,h_work_R) - - do k=nk,k_max+1,-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - endif - - if ( SUM(h_means) == 0. .or. F_bulk == 0.) then - return - ! Decompose the bulk flux onto the individual layers - else - ! Initialize remaining thickness - inv_heff = 1./SUM(h_means) - do k=1,nk - if ((h_means(k) > 0.) .and. (phi_L(k) /= phi_R(k))) then - hfrac = h_means(k)*inv_heff - F_layer(k) = F_bulk * hfrac - - if (limiter) then - ! 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(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) - - ! check if bulk flux (or F_layer) and F_max have same direction - if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer(k) = MIN(F_layer(k),F_max) - else - F_layer(k) = MAX(F_layer(k),F_max) - endif - else - ! do not apply a flux on this layer - F_layer(k) = 0. - endif - else - dphi = -(phi_R(k) - phi_L(k)) - if (.not. SIGN(1.,F_bulk) == SIGN(1., dphi)) then - ! upgradient, do not apply a flux on this layer - F_layer(k) = 0. - endif - endif ! limited - endif - enddo - endif - -end subroutine fluxes_bulk_method !> Unit tests for near-boundary horizontal mixing logical function near_boundary_unit_tests( verbose ) @@ -1183,16 +878,16 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. ! Without limiter - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) - ! same as above, but with limiter - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, .true.) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-1.0/) ) + !! same as above, but with limiter + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, .true.) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-1.0/) ) test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' hbl_L = 10.; hbl_R = 10. @@ -1207,10 +902,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) test_name = 'Equal hbl and same layer thicknesses (no gradient)' hbl_L = 10; hbl_R = 10 @@ -1225,10 +920,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' hbl_L = 16.; hbl_R = 16. @@ -1243,10 +938,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' hbl_L = 10.; hbl_R = 10. @@ -1261,10 +956,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 @@ -1279,10 +974,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) @@ -1299,10 +994,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right' hbl_L = 2; hbl_R = 2 @@ -1317,10 +1012,10 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + !near_boundary_unit_tests = near_boundary_unit_tests .or. & + ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' hbl_L = 2; hbl_R = 2 From 75c587e5f7855babd2b36a91c55b84f040709f7a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 2 Oct 2020 16:46:45 -0600 Subject: [PATCH 027/212] Major re-arragement to remap u- and v-fluxes For each tracer point: * tracers at (I,j), (I+1,j), (i,J) and (i,J+1) are remapped to a defined zgrid; * Apply LBD, uflux and vflux are calculated using the zgrid * Remap fluxes to native grid * Apply tracer convergence in the native grid TODO: * cleanup * create a zgrid for each pair of column taking into consideration h_L, h_R, BLD_L and BLD_R. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 341 +++++++++++++++--- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 2 files changed, 282 insertions(+), 61 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index f218f21798..0c068613a5 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -7,9 +7,11 @@ module MOM_lateral_boundary_diffusion 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_domains, only : pass_var +use MOM_checksums, only : hchksum_pair, hchksum +use MOM_domains, only : pass_var, sum_across_PEs 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, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_file_parser, only : openParameterBlock, closeParameterBlock @@ -41,19 +43,20 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lbd_CS ; private - integer :: deg !< Degree of polynomial reconstruction - integer :: nk !< Number of layers in dz_top - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP - 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, dimension(:), allocatable :: dz_top !< top vertical grid to remap the state before applying lateral diffusion - real, dimension(:), allocatable :: dz_bot !< bot vertical grid to remap the state before applying lateral diffusion - 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. + logical :: debug !< If true, write verbose checksums for debugging. + integer :: deg !< Degree of polynomial reconstruction. + integer :: nk !< Number of layers in dz_top. + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + 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, dimension(:), allocatable :: dz_top !< top vertical grid to remap the state before applying lateral diffusion. + real, dimension(:), allocatable :: dz_bot !< bot vertical grid to remap the state before applying lateral diffusion. + 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". @@ -123,8 +126,12 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& + check_reconstruction = .true., check_remapping = .true.) 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.) ! set dz_top call get_param(param_file, mdl, "LBD_DIAG_COORD_TOP", string, & "Determines how to specify the vertical resolution "//& @@ -239,25 +246,28 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - !real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] - real, dimension(SZIB_(G),SZJ_(G),CS%nk) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] - real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer - !real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] - real, dimension(SZI_(G),SZJB_(G),CS%nk) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] - real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] + !real, dimension(SZIB_(G),SZJ_(G),CS%nk) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] + !real, dimension(SZI_(G),SZJB_(G),CS%nk) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diag in the zgrid - real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z !< Tracer in the zgrid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic +! real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z !< Tracer in the zgrid 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(SZK_(GV)) :: tracer_1d !< 1d-array used to remap tracer change to native grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, !! only used to compute tendencies. - real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z_old!< Copy of the initial tracer concentration in z-space - +! real, dimension(SZI_(G),SZJ_(G),CS%nk) :: diff_z !< Used to store difference in tracer concentration in +! !! z-space after applying diffusion. + real, dimension(SZI_(G),SZJ_(G)) :: tracer_int, tracer_end + !< integrated tracer in the native grid, before and after + ! LBD is applied. integer :: remap_method !< Reconstruction method - integer :: i,j,k,m !< indices to loop over + integer :: i, j, k, m !< indices to loop over real :: Idt !< inverse of the time step [s-1] + real :: tmpReal, tmp1, tmp2 Idt = 1./dt hbl(:,:) = 100. @@ -267,29 +277,57 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call pass_var(hbl,G%Domain) do m = 1,Reg%ntr + ! initialize arrays with zeros +! tracer_z(:,:,:) = 0.0 +! diff_z(:,:,:) = 0.0 + + ! current tracer tracer => Reg%tr(m) - tracer_z(:,:,:) = 0.0 - tracer_z_old(:,:,:) = 0.0 + call pass_var(tracer%t,G%Domain) + + if (CS%debug) then + tracer_old(:,:,:) = 0.0 + tracer_old(:,:,:) = tracer%t(:,:,:) + endif + ! for diagnostics if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then tendency(:,:,:) = 0.0 - tracer_old(:,:,:) = 0.0 - ! copy initial tracer state so that the tendency can be computed - tracer_old(:,:,:) = tracer%t(:,:,:) endif ! remap tracer to zgrid - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - call remapping_core_h(CS%remap_cs, G%ke, h(i,j,:), tracer%t(i,j,:), CS%nk, CS%dz_top(:), tracer_z(i,j,:)) - !call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & - ! ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) - enddo ; enddo + !! do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + !! tmpReal = SUM(h(i,j,:)) + !! call remapping_core_h(CS%remap_cs, G%ke, h(i,j,:), tracer%t(i,j,:), CS%nk, CS%dz_top(:), tracer_z(i,j,:)) + !! !call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & + !! ! ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) + !! enddo ; enddo + + !! if (CS%debug) then + !! tracer_int(:,:) = 0.0; tracer_z_int(:,:) = 0.0 + !! ! native + !! do j=G%jsc,G%jec ; do i=G%isc,G%iec + !! do k=1,G%ke + !! tracer_int(i,j) = tracer_int(i,j) + tracer%t(i,j,k) * & + !! (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) + !! enddo + !! ! zgrid + !! do k=1,CS%nk + !! tracer_z_int(i,j) = tracer_z_int(i,j) + tracer_z(i,j,k) * & + !! (CS%dz_top(k)*(G%mask2dT(i,j)*G%areaT(i,j))) + !! enddo + !! enddo; enddo + + !! tmp1 = SUM(tracer_int) + !! tmp2 = SUM(tracer_z_int) + !! call sum_across_PEs(tmp1) + !! call sum_across_PEs(tmp2) + !! if (is_root_pe()) write(*,*)'Total tracer, native and z:',tracer%name, tmp1, tmp2 + !! endif ! Diffusive fluxes in the i- and j-direction - uFlx(:,:,:) = 0. ! z-space - vFlx(:,:,:) = 0. ! z-space - uFlx_bulk(:,:) = 0. - vFlx_bulk(:,:) = 0. + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. ! LBD layer by layer do j=G%jsc,G%jec @@ -299,9 +337,12 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & ! ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & ! uFlx(I,j,:), CS) - call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & - remap_method, Coef_x(I,j), uFlx(I,j,:), CS) + !call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & + ! G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & + ! Coef_x(I,j), uFlx(I,j,:), CS) + call fluxes_layer_method2(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,:), CS) endif enddo enddo @@ -312,31 +353,65 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & ! ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & ! vFlx(i,J,:), CS) - call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & - remap_method, Coef_y(i,J), vFlx(i,J,:), CS) + !call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & + ! G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & + ! Coef_y(i,J), vFlx(i,J,:), CS) + call fluxes_layer_method2(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,:), CS) endif enddo enddo ! Update the tracer fluxes - do k=1,CS%nk ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + 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)) - tracer_z(i,j,k) = tracer_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) + 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)) + !tracer_z(i,j,k) = tracer_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) + !diff_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) ! difference between before/after diffusion in the zgrid - tendency_z(i,j,k) = tracer_z(i,j,k) - tracer_z_old(i,j,k) + !diff_z(i,j,k) = tracer_z(i,j,k) - tracer_z_old(i,j,k) endif enddo ; enddo ; enddo - ! remap tracer "change" back to native grid - do j=G%jsc,G%jec ; do i=G%isc,G%iec - tracer_1d(:) = 0.0 - call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, tendency_z(i,j,:), G%ke, h(i,j,:), tracer_1d(:)) - tracer%t(i,j,:) = tracer%t(i,j,:) + tracer_1d(:) - enddo ; enddo + ! remap the tracer "change" back to the native grid + !do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! tracer_1d(:) = 0.0 + ! call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) + ! uh_dest = uh_dest/h_dest + ! call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, diff_z(i,j,:), G%ke, h(i,j,:), tracer_1d(:)) + ! tracer%t(i,j,:) = tracer%t(i,j,:) + tracer_1d(:) + + ! if (CS%debug) then + ! tmp1 = SUM(tracer%t(i,j,:)*h(i,j,:)) + ! tmp2 = SUM((tracer_z(i,j,:)+diff_z(i,j,:))*CS%dz_top(:)) + ! call sum_across_PEs(tmp1) + ! call sum_across_PEs(tmp2) + ! write(*,*)'After LBD: native sum, ',tmp1 + ! write(*,*)'After LBD: zstar sum, ', tmp2 + ! endif + !enddo ; enddo + if (CS%debug) then + tracer_int(:,:) = 0.0; tracer_end(:,:) = 0.0 + ! tracer (native grid) before and after LBD + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,GV%ke + tracer_int(i,j) = tracer_int(i,j) + tracer_old(i,j,k) * & + (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) + tracer_end(i,j) = tracer_end(i,j) + tracer%t(i,j,k) * & + (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) + enddo + enddo; enddo + + tmp1 = SUM(tracer_int) + tmp2 = SUM(tracer_end) + call sum_across_PEs(tmp1) + call sum_across_PEs(tmp2) + if (is_root_pe()) write(*,*)'Total tracer, before/after:', tmp1, tmp2 + endif if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -470,10 +545,157 @@ 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. +!! See \ref section_method2 +subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 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 delta t + !! 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] + type(lbd_CS), pointer :: CS !< Lateral diffusion control structure + !! the boundary layer + ! Local variables + real, dimension(CS%nk) :: phi_L_z, phi_R_z !< Tracer values in the ztop grid (left, right) [conc] + real, dimension(CS%nk) :: F_layer_z !< Diffusive flux at U- or V-point 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 :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + !! This is just to remind developers that khtr_avg should be + !! computed once khtr is 3D. + real :: htot !< Total column thickness [H ~> m or kg m-2] + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively + integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively + integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively + 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 :: hbl_min !< minimum BLD (left and right) [m] + 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 + + F_layer(:) = 0.0; F_layer_z(:) = 0.0 + if (hbl_L == 0. .or. hbl_R == 0.) then + return + endif + + ! TODO: here is where new vertical grid is defined + !CS%dz_top(:) + + ! remap tracer to zgrid + phi_L_z(:) = 0.0; phi_R_z(:) = 0.0 + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), CS%nk, CS%dz_top(:), phi_L_z(:)) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), CS%nk, CS%dz_top(:), phi_R_z(:)) + + if (CS%debug) then + tmp1 = SUM(phi_L(:)*h_L(:)) + tmp2 = SUM(phi_L_z(:)*CS%dz_top(:)) + call sum_across_PEs(tmp1) + call sum_across_PEs(tmp2) + if (is_root_pe()) write(*,*)'Total tracer, native and z (L):', tmp1, tmp2 + tmp1 = SUM(phi_R(:)*h_R(:)) + tmp2 = SUM(phi_R_z(:)*CS%dz_top(:)) + call sum_across_PEs(tmp1) + call sum_across_PEs(tmp2) + if (is_root_pe()) write(*,*)'Total tracer, native and z (R):', tmp1, tmp2 + endif + + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, CS%nk, CS%dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, CS%nk, CS%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) + + ! make sure left and right k indices span same range + if (k_bot_min .ne. k_bot_L) then + k_bot_L = k_bot_min + zeta_bot_L = 1.0 + endif + if (k_bot_min .ne. k_bot_R) then + k_bot_R= k_bot_min + zeta_bot_R = 1.0 + endif + + ! tracer flux where the minimum BLD intersets layer + ! GMM, khtr_avg should be computed once khtr is 3D + if ((CS%linear) .and. (k_bot_diff .gt. 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min-1,1,-1 + F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + enddo + htot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + htot = htot + CS%dz_top(k) + enddo + + a = -1.0/htot + htot = 0.0 + do k = k_bot_min,k_bot_max, 1 + wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 + F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + htot = htot + CS%dz_top(k) + enddo + else + do k = k_bot_min-1,1,-1 + F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + enddo + endif + endif + +! 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 .ne. k_top_L) then +! k_top_L = k_top_max +! zeta_top_L = 1.0 +! endif +! if (k_top_max .ne. 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 + + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + enddo + ! remap flux to native grid + call reintegrate_column(CS%nk, CS%dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + do k = 1,ke + F_layer(k) = F_layer(k)/h_vel(k) + enddo + +end subroutine fluxes_layer_method2 + !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method1 subroutine fluxes_layer_method1(boundary, nk, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - method, khtr_u, F_layer, CS) + khtr_u, F_layer, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers in the local z-grid [nondim] @@ -485,7 +707,6 @@ subroutine fluxes_layer_method1(boundary, nk, hbl_L, hbl_R, area_L, area_R, phi_ real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 3a335c82d4..3cfb771bc1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -316,7 +316,7 @@ 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 hbl(:,:) = 100. - hbl(4:6,:) = 500. + hbl(4:6,:) = 100. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) From 441c34ef42e1b994e0c8fe241bbf0b7bea5be1e1 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 6 Oct 2020 16:25:36 -0600 Subject: [PATCH 028/212] Define vertical grid on-the-fly using h's and BLDs * Add functions to merge thicknesses and BLDs * z_top is now defined every time-step using this information * added unit tests --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 373 ++++++++++++++---- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 2 files changed, 293 insertions(+), 82 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 0c068613a5..2604756268 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -271,60 +271,24 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 100. - hbl(4:6,:) = 100. + hbl(4:6,:) = 500. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) do m = 1,Reg%ntr - ! initialize arrays with zeros -! tracer_z(:,:,:) = 0.0 -! diff_z(:,:,:) = 0.0 - ! current tracer tracer => Reg%tr(m) call pass_var(tracer%t,G%Domain) - - if (CS%debug) then - tracer_old(:,:,:) = 0.0 - tracer_old(:,:,:) = tracer%t(:,:,:) - endif + write(*,*)' ##### tracer name ######', tracer%name ! for diagnostics - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then + 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(:,:,:) = 0.0 + tracer_old(:,:,:) = tracer%t(:,:,:) endif - ! remap tracer to zgrid - !! do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - !! tmpReal = SUM(h(i,j,:)) - !! call remapping_core_h(CS%remap_cs, G%ke, h(i,j,:), tracer%t(i,j,:), CS%nk, CS%dz_top(:), tracer_z(i,j,:)) - !! !call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & - !! ! ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) - !! enddo ; enddo - - !! if (CS%debug) then - !! tracer_int(:,:) = 0.0; tracer_z_int(:,:) = 0.0 - !! ! native - !! do j=G%jsc,G%jec ; do i=G%isc,G%iec - !! do k=1,G%ke - !! tracer_int(i,j) = tracer_int(i,j) + tracer%t(i,j,k) * & - !! (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) - !! enddo - !! ! zgrid - !! do k=1,CS%nk - !! tracer_z_int(i,j) = tracer_z_int(i,j) + tracer_z(i,j,k) * & - !! (CS%dz_top(k)*(G%mask2dT(i,j)*G%areaT(i,j))) - !! enddo - !! enddo; enddo - - !! tmp1 = SUM(tracer_int) - !! tmp2 = SUM(tracer_z_int) - !! call sum_across_PEs(tmp1) - !! call sum_across_PEs(tmp2) - !! if (is_root_pe()) write(*,*)'Total tracer, native and z:',tracer%name, tmp1, tmp2 - !! endif - ! Diffusive fluxes in the i- and j-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. @@ -377,23 +341,6 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif enddo ; enddo ; enddo - ! remap the tracer "change" back to the native grid - !do j=G%jsc,G%jec ; do i=G%isc,G%iec - ! tracer_1d(:) = 0.0 - ! call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - ! uh_dest = uh_dest/h_dest - ! call remapping_core_h(CS%remap_cs, CS%nk, CS%dz_top, diff_z(i,j,:), G%ke, h(i,j,:), tracer_1d(:)) - ! tracer%t(i,j,:) = tracer%t(i,j,:) + tracer_1d(:) - - ! if (CS%debug) then - ! tmp1 = SUM(tracer%t(i,j,:)*h(i,j,:)) - ! tmp2 = SUM((tracer_z(i,j,:)+diff_z(i,j,:))*CS%dz_top(:)) - ! call sum_across_PEs(tmp1) - ! call sum_across_PEs(tmp2) - ! write(*,*)'After LBD: native sum, ',tmp1 - ! write(*,*)'After LBD: zstar sum, ', tmp2 - ! endif - !enddo ; enddo if (CS%debug) then tracer_int(:,:) = 0.0; tracer_end(:,:) = 0.0 ! tracer (native grid) before and after LBD @@ -480,6 +427,170 @@ real function harmonic_mean(h1,h2) endif end function harmonic_mean +!> 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) + 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 + real, dimension(nk+1) :: eta_L, eta_R !< Interfaces in the left and right coloumns + real, dimension(:), allocatable :: eta1 !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R + real, dimension(:), allocatable :: eta2 !< Combined interfaces (eta1), plus hbl_L and hbl_R + integer :: k, nk1, nk2 + logical :: add_hbl_L, add_hbl_R + + add_hbl_L = .true.; add_hbl_R = .true. + + ! compute interfaces + eta_L(:) = 0.0; eta_R(:) = 0.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) + enddo + + ! build array with interfaces from eta_L and eta_R + allocate(eta1(1)) + eta1(1) = 0.0 + do k=2,nk+1 + if (eta_L(k) == eta_R(k)) then + ! add just one of them + if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) + elseif (eta_L(k) > eta_R(k)) then + ! add eta_R first + if (eta_R(k) /= eta_R(k-1)) call add_to_list(eta1, eta_R(k)) + if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) + else + ! add eta_L first + if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) + if (eta_R(k) /= eta_R(k-1)) call add_to_list(eta1, eta_R(k)) + endif + enddo + + !write(*,*)'eta1, SIZE(eta1)',eta1(:), SIZE(eta1) + ! check if hbl_L and hbl_R exist in eta1. If not, add them. + nk1 = SIZE(eta1) + + do k=1,nk1 + if (eta1(k) == hbl_L) add_hbl_L = .false. + if (eta1(k) == hbl_R) add_hbl_R = .false. + enddo + if (hbl_L == hbl_R) then + ! only add hbl_L + add_hbl_R = .false. + endif + + if (add_hbl_L .and. add_hbl_R) then + ! add both hbl_L and hbl_R + nk2 = nk1 + 2 + allocate(eta2(nk2)) + call add_two_interfaces(nk1, eta1, hbl_L, hbl_R, eta2) + elseif (add_hbl_L) then + ! only add hbl_L + nk2 = nk1 + 1 + allocate(eta2(nk2)) + call add_one_interface(nk1, eta1, hbl_L, eta2) + elseif (add_hbl_R) then + ! only add hbl_R + nk2 = nk1 + 1 + allocate(eta2(nk2)) + call add_one_interface(nk1, eta1, hbl_R, eta2) + else + ! both hbl_L and hbl_R already exist + nk2 = nk1 + allocate(eta2(nk2)) + do k=1,nk2 + eta2(k) = eta1(k) + enddo + endif + + !write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) + + allocate(h(nk2-1)) + do k=1,nk2-1 + h(k) = eta2(k+1) - eta2(k) + enddo + !write(*,*)'h ',h(:) + +end subroutine merge_interfaces + +subroutine add_two_interfaces(nk, eta, val1, val2, new_eta) + integer, intent(in ) :: nk !< number of layers in eta + real, dimension(nk), intent(in ) :: eta !< intial interfaces + real, intent(in ) :: val1 !< first interface to be added + real, intent(in ) :: val2 !< second interface to be added + real, dimension(nk+2), intent(inout) :: new_eta !< final interfaces + + ! local variables + integer :: k, k_new + real, dimension(nk+1) :: eta_tmp + + call add_one_interface(nk, eta, val1, eta_tmp) + call add_one_interface(nk+1, eta_tmp, val2, new_eta) + +end subroutine add_two_interfaces + +subroutine add_one_interface(nk, eta, new_val, new_eta) + integer, intent(in ) :: nk !< number of layers in eta + real, dimension(nk), intent(in ) :: eta !< intial interfaces + real, intent(in ) :: new_val !< interface to be added + real, dimension(nk+1), intent(inout) :: new_eta !< final interfaces + + ! local variables + integer :: k, k_new + + new_eta(:) = 0.0 + k_new = 1 + do k=1,nk-1 + if ((new_val > eta(k)) .and. (new_val < eta(k+1))) then + new_eta(k_new) = eta(k) + new_eta(k_new+1) = new_val + k_new = k_new + 2 + else + new_eta(k_new) = eta(k) + k_new = k_new + 1 + endif + enddo + new_eta(nk+1) = eta(nk) + +end subroutine add_one_interface + +subroutine add_to_list(list, element) + real, intent(in) :: element + real, dimension(:), allocatable, intent(inout) :: list + + ! local variables + integer :: i, isize + real, dimension(:), allocatable :: clist + + + if(allocated(list)) then + isize = size(list) + allocate(clist(isize+1)) + do i=1,isize + clist(i) = list(i) + end do + clist(isize+1) = element + + deallocate(list) + call move_alloc(clist, list) + + else + allocate(list(1)) + list(1) = element + end if + +end subroutine add_to_list + !> 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] @@ -567,10 +678,12 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer ! Local variables - real, dimension(CS%nk) :: phi_L_z, phi_R_z !< Tracer values in the ztop grid (left, right) [conc] - real, dimension(CS%nk) :: F_layer_z !< Diffusive flux at U- or V-point 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(:), allocatable :: dz_top + real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] + real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] + real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U- or V-point 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 :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. @@ -588,36 +701,47 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi 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 + integer :: nk - F_layer(:) = 0.0; F_layer_z(:) = 0.0 + F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif - ! TODO: here is where new vertical grid is defined - !CS%dz_top(:) + ! Define vertical grid, dz_top + call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, dz_top) + !allocate(dz_top(1000)); dz_top(:) = 0.5 + nk = SIZE(dz_top) + + ! allocate arrays + allocate(phi_L_z(nk)); phi_L_z(:) = 0.0 + allocate(phi_R_z(nk)); phi_R_z(:) = 0.0 + allocate(F_layer_z(nk)); F_layer_z(:) = 0.0 - ! remap tracer to zgrid - phi_L_z(:) = 0.0; phi_R_z(:) = 0.0 - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), CS%nk, CS%dz_top(:), phi_L_z(:)) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), CS%nk, CS%dz_top(:), phi_R_z(:)) + ! remap tracer to dz_top + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) + + !do k=1,nk + ! write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) + !enddo if (CS%debug) then tmp1 = SUM(phi_L(:)*h_L(:)) - tmp2 = SUM(phi_L_z(:)*CS%dz_top(:)) + tmp2 = SUM(phi_L_z(:)*dz_top(:)) call sum_across_PEs(tmp1) call sum_across_PEs(tmp2) if (is_root_pe()) write(*,*)'Total tracer, native and z (L):', tmp1, tmp2 tmp1 = SUM(phi_R(:)*h_R(:)) - tmp2 = SUM(phi_R_z(:)*CS%dz_top(:)) + tmp2 = SUM(phi_R_z(:)*dz_top(:)) call sum_across_PEs(tmp1) call sum_across_PEs(tmp2) if (is_root_pe()) write(*,*)'Total tracer, native and z (R):', tmp1, tmp2 endif ! Calculate vertical indices containing the boundary layer in dz_top - call boundary_k_range(boundary, CS%nk, CS%dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, CS%nk, CS%dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + 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) @@ -639,23 +763,23 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi if ((CS%linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 - F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) enddo htot = 0.0 do k = k_bot_min+1,k_bot_max, 1 - htot = htot + CS%dz_top(k) + htot = htot + dz_top(k) enddo a = -1.0/htot htot = 0.0 do k = k_bot_min,k_bot_max, 1 - wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt - htot = htot + CS%dz_top(k) + 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) enddo else - do k = k_bot_min-1,1,-1 - F_layer_z(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) enddo endif endif @@ -681,15 +805,24 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi ! enddo ! endif + do k=1,nk + write(*,*)'F_layer_z(k)',F_layer_z(k) + enddo + do k = 1,ke h_vel(k) = harmonic_mean(h_L(k), h_R(k)) enddo ! remap flux to native grid - call reintegrate_column(CS%nk, CS%dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) do k = 1,ke F_layer(k) = F_layer(k)/h_vel(k) enddo + ! deallocated arrays + deallocate(dz_top) + deallocate(phi_L_z) + deallocate(phi_R_z) + deallocate(F_layer_z) end subroutine fluxes_layer_method2 !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. @@ -1004,6 +1137,9 @@ logical function near_boundary_unit_tests( verbose ) integer, parameter :: nk = 2 ! Number of layers integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) integer, parameter :: method = 1 ! Method used for integrating polynomials + real, dimension(nk+2) :: eta1 ! Updated interfaces with one extra value [m] + real, dimension(nk+3) :: eta2 ! Updated interfaces with two extra values [m] + real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) real, dimension(nk,deg+1) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions @@ -1028,6 +1164,7 @@ logical function near_boundary_unit_tests( verbose ) area_L = 1.; area_R = 1. ! Set to unity for all unit tests 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' @@ -1084,6 +1221,78 @@ logical function near_boundary_unit_tests( verbose ) 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 adding interfaces + test_name = 'Add one interface' + call add_one_interface(nk+1, (/0., 2., 4./), 1., eta1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, eta1, (/0., 1., 2., 4./) ) + + test_name = 'Add two interfaces' + call add_two_interfaces(nk+1, (/0., 2., 4./), 1., 3., eta2) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+3, test_name, eta2, (/0., 1., 2., 3., 4./) ) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed add interfaces' + + ! 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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/1., 0.5, 1.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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, h1, (/0.5, 0.5, 0.5, 1.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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 0.5, 0.5, 2./) ) + 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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+3, test_name, h1, (/0.5, 0.5, 0.5, 0.5, 2./) ) + 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, 1.0, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., 2., 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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/2., 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, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/1., 1., 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./), 2.0, 2.0, 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 has zero thickness, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/2., 2./), (/0., 4./), 1.0, 2.0, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/1., 1., 2./) ) + 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 = 10; hbl_R = 10 @@ -1293,6 +1502,8 @@ logical function near_boundary_unit_tests( verbose ) ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) !near_boundary_unit_tests = near_boundary_unit_tests .or. & ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,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 diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 3cfb771bc1..3a335c82d4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -316,7 +316,7 @@ 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 hbl(:,:) = 100. - hbl(4:6,:) = 100. + hbl(4:6,:) = 500. !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) !if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) From d13efbe1c55d8989481ef90a6ad90379c3cecaff Mon Sep 17 00:00:00 2001 From: Rahul Mahajan Date: Thu, 8 Oct 2020 17:41:15 -0400 Subject: [PATCH 029/212] fix fieldwidth error with gfortran --- config_src/nuopc_driver/mom_cap.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ce11cfb3f9..8d48607281 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -295,7 +295,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_count + read(value, *, iostat=iostat) scalar_field_count if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldCount not an integer: "//trim(value), & @@ -311,7 +311,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx + read(value, *, iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & @@ -327,7 +327,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny + read(value, *, iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & @@ -700,16 +700,16 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") if (ocean_state%use_waves) then - if (Ice_ocean_boundary%num_stk_bands > 3) then + if (Ice_ocean_boundary%num_stk_bands > 3) then call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") - endif + endif call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_1" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_1", "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_2" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_2", "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_3" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_3", "will provide") - endif + endif !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") @@ -1746,7 +1746,7 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) endif else - ! restart_n is zero, restarts will be written at finalize only (no alarm control) + ! restart_n is zero, restarts will be written at finalize only (no alarm control) restart_mode = 'no_alarms' call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) endif From 40136b6d2241495463713efa35e36f56e436ff88 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Oct 2020 16:52:47 -0600 Subject: [PATCH 030/212] Passes GV to lateral_boundary_diffusion_init --- src/core/MOM.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bb2a5bc04a..cf1f2fbe42 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2608,7 +2608,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) - call tracer_hor_diff_init(Time, G, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & + call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & CS%tracer_diff_CSp) call lock_tracer_registry(CS%tracer_Reg) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 89ab479903..a8feef1bf0 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1430,9 +1430,10 @@ end subroutine tracer_epipycnal_ML_diff !> Initialize lateral tracer diffusion module -subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp, CS) +subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic_CSp, 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 !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< diagnostic control type(EOS_type), target, intent(in) :: EOS !< Equation of state CS @@ -1511,7 +1512,7 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp 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, param_file, diag, diabatic_CSp, & + 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_neutral_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!") From e537ef2338cc1c6db5d80c6817511da38bc1f07c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Oct 2020 16:53:52 -0600 Subject: [PATCH 031/212] Add option to initialize passive tracer from z file --- src/tracer/MOM_tracer_flow_control.F90 | 4 ++- src/tracer/tracer_example.F90 | 47 +++++++++++++++++++------- 2 files changed, 38 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index a9bf9a03d9..40826dbaa6 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -308,8 +308,10 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & - call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & + call USER_initialize_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS%USER_tracer_example_CSp, & sponge_CSp) + !call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & + ! 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) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 0897253e15..d52a4045b9 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -4,7 +4,7 @@ module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. 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 @@ -18,6 +18,7 @@ module USER_tracer_example use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux @@ -41,7 +42,7 @@ module USER_tracer_example 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. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. - + logical :: from_z !< if true, initialize tracers from a z file. integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -101,6 +102,10 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) + call get_param(param_file, mdl, "TRACER_EXAMPLE_FROM_Z", CS%from_z, & + "If true, initialize tracers from a z file "//& + "using MOM_initialize_tracer_from_Z.", default=.false.) + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 do m=1,NTR @@ -136,15 +141,18 @@ end function USER_register_tracer_example !> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & +subroutine USER_initialize_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & 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(in) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + 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(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies @@ -180,14 +188,29 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (.not.restart) then if (len_trim(CS%tracer_IC_file) >= 1) then -! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & - call MOM_error(FATAL, "USER_initialize_tracer: Unable to open "// & - CS%tracer_IC_file) - do m=1,NTR - call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") - call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) - enddo + if (CS%from_z) then + ! Read the tracer concentrations from a netcdf file on a z grid. + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") + call MOM_error(NOTE,"USER_initialize_tracer: "//& + "initializing tracer "//trim(name)//& + " using MOM_initialize_tracer_from_Z ") + tr_ptr => CS%tr(:,:,:,m) + call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & + src_file = CS%tracer_IC_file, & + src_var_nam = name, & + useALEremapping = .true. ) + enddo + else + ! Read the tracer concentrations from a netcdf file on the native grid. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "USER_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + endif else do m=1,NTR do k=1,nz ; do j=js,je ; do i=is,ie From 365b298bed907e396ff63eeae138c14411d3251b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Oct 2020 16:54:45 -0600 Subject: [PATCH 032/212] Cleanup + add unit tests --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 736 +++--------------- 1 file changed, 96 insertions(+), 640 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 2604756268..6f09de371d 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -45,13 +45,13 @@ module MOM_lateral_boundary_diffusion type, public :: lbd_CS ; private logical :: debug !< If true, write verbose checksums for debugging. integer :: deg !< Degree of polynomial reconstruction. - integer :: nk !< Number of layers in dz_top. integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP 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, dimension(:), allocatable :: dz_top !< top vertical grid to remap the state before applying lateral diffusion. - real, dimension(:), allocatable :: dz_bot !< bot vertical grid to remap the state before applying lateral diffusion. + 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. @@ -67,9 +67,10 @@ module MOM_lateral_boundary_diffusion !> 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, param_file, diag, diabatic_CSp, CS) +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 @@ -105,6 +106,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab 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) @@ -132,95 +134,6 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab call get_param(param_file, mdl, "LBD_DEBUG", CS%debug, & "If true, write out verbose debugging data in the LBD module.", & default=.false.) - ! set dz_top - call get_param(param_file, mdl, "LBD_DIAG_COORD_TOP", string, & - "Determines how to specify the vertical resolution "//& - "to apply lateral diffusion near the surface. Valid options are:\n"//& - " PARAM - use the vector-parameter LBD_DZ_TOP \n"//& - " UNIFORM[:N] - uniformly distributed\n"//& - " FILE:string - read from a file. The string specifies\n"//& - " the filename and variable name, separated\n"//& - " by a comma or space, e.g. FILE:lev.nc,dz\n"//& - " or FILE:lev.nc,interfaces=zw\n",& - default="UNIFORM:500,500") - message = "The distribution of vertical resolution used to \n"//& - "apply lateral diffusion near boundaries." - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "NK", nk, & - "The number of model layers.", units="nondim", fail_if_missing=.true., & - do_not_log=.true.) - if (index(trim(string),'UNIFORM')==1) then - call get_param(param_file, "MOM", "MAXIMUM_DEPTH", tmpReal, & - "The maximum depth of the ocean.", units="m", default=4000.0, do_not_log=.true.) - if (len_trim(string)==7) then - ke = nk ! Use model nk by default - elseif (index(trim(string),'UNIFORM:')==1 .and. len_trim(string)>8) then - ! Format is "UNIFORM:N" or "UNIFORM:N,MAX_DEPTH" - ke = extract_integer(string(9:len_trim(string)),'',1) - tmpReal = extract_real(string(9:len_trim(string)),',',2,missing_value=tmpReal) - else - call MOM_error(FATAL,trim(mdl)//', lateral_boundary_diffusion_init: '// & - 'Unable to interpret "'//trim(string)//'".') - endif - allocate(CS%dz_top(ke)) - CS%dz_top(:) = tmpReal / real(ke) - call log_param(param_file, mdl, "!LBD_DZ_TOP", CS%dz_top, & - trim(message), units='m') - elseif (trim(string)=='PARAM') then - ke = nk ! Use model nk by default - allocate(CS%dz_top(ke)) - call get_param(param_file, mdl, 'LBD_DZ_TOP', CS%dz_top, & - trim(message), units='m', fail_if_missing=.true.) - elseif (index(trim(string),'FILE:')==1) then - ! FILE:filename,var_name is assumed to be reading level thickness variables - ! FILE:filename,interfaces=var_name reads positions - if (string(6:6)=='.' .or. string(6:6)=='/') then - ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path - fileName = trim( extractWord(trim(string(6:80)), 1) ) - else - ! Otherwise assume we should look for the file in INPUTDIR - fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) - endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") - - varName = trim( extractWord(trim(string(6:)), 2) ) - if (len_trim(varName)==0) then - if (field_exists(fileName,'dz')) then; varName = 'dz' - else ; call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & - "Coordinate variable (dz) not specified and none could be guessed.") - endif - endif - expected_units = 'meters' - if (index(trim(varName),'interfaces=')==1) then - varName=trim(varName(12:)) - call check_grid_def(filename, varName, expected_units, message, ierr) - if (ierr) call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "//& - "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) - call field_size(trim(fileName), trim(varName), nzf) - ke = nzf(1)-1 - allocate(CS%dz_top(ke)) - allocate(z_max(ke+1)) - call MOM_read_data(trim(fileName), trim(varName), z_max) - CS%dz_top(:) = abs(z_max(1:ke) - z_max(2:ke+1)) - deallocate(z_max) - else - ! Assume reading resolution - call field_size(trim(fileName), trim(varName), nzf) - ke = nzf(1) - allocate(CS%dz_top(ke)) - call MOM_read_data(trim(fileName), trim(varName), CS%dz_top) - endif - call log_param(param_file, mdl, "!LBD_DZ_TOP", CS%dz_top, & - trim(message), units='m') - else - call MOM_error(FATAL,trim(mdl)//", lateral_boundary_diffusion_init: "// & - "Unrecognized coordinate configuration"//trim(string)) - endif - CS%nk = ke - ! TODO: set dz_bot - CS%dz_bot(:) = 1.0 end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. @@ -297,14 +210,7 @@ subroutine lateral_boundary_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, GV%ke, CS%nk, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - ! G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ! ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & - ! uFlx(I,j,:), CS) - !call fluxes_layer_method1(SURFACE, CS%nk, hbl(I,j), hbl(I+1,j), & - ! G%areaT(I,j), G%areaT(I+1,j), tracer_z(I,j,:), tracer_z(I+1,j,:), & - ! Coef_x(I,j), uFlx(I,j,:), CS) - call fluxes_layer_method2(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + 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,:), CS) endif @@ -313,14 +219,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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, CS%nk, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - ! G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ! ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & - ! vFlx(i,J,:), CS) - !call fluxes_layer_method1(SURFACE, CS%nk, hbl(i,J), hbl(i,J+1), & - ! G%areaT(i,J), G%areaT(i,J+1), tracer_z(i,J,:), tracer_z(i,J+1,:), & - ! Coef_y(i,J), vFlx(i,J,:), CS) - call fluxes_layer_method2(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & + 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,:), CS) endif @@ -331,13 +230,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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)) - !tracer_z(i,j,k) = tracer_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) - !diff_z(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)/( CS%dz_top(k) + GV%H_subroundoff)) - ! difference between before/after diffusion in the zgrid - !diff_z(i,j,k) = tracer_z(i,j,k) - tracer_z_old(i,j,k) + G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) endif enddo ; enddo ; enddo @@ -367,8 +260,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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>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 @@ -406,7 +299,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! 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) + GV%H_subroundoff ) + 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 @@ -431,16 +324,16 @@ end function harmonic_mean !! 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) - 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] +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 real, dimension(nk+1) :: eta_L, eta_R !< Interfaces in the left and right coloumns @@ -513,13 +406,13 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, h) enddo endif - !write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) + write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) allocate(h(nk2-1)) do k=1,nk2-1 - h(k) = eta2(k+1) - eta2(k) + h(k) = (eta2(k+1) - eta2(k)) + H_subroundoff enddo - !write(*,*)'h ',h(:) + write(*,*)'h ',h(:) end subroutine merge_interfaces @@ -657,8 +550,8 @@ 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. -!! See \ref section_method2 -subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & +!! 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, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] @@ -709,7 +602,7 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi endif ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, dz_top) + call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) !allocate(dz_top(1000)); dz_top(:) = 0.5 nk = SIZE(dz_top) @@ -722,9 +615,9 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) - !do k=1,nk - ! write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) - !enddo + do k=1,nk + write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) + enddo if (CS%debug) then tmp1 = SUM(phi_L(:)*h_L(:)) @@ -815,7 +708,8 @@ subroutine fluxes_layer_method2(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi ! remap flux to native grid call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) do k = 1,ke - F_layer(k) = F_layer(k)/h_vel(k) + F_layer(k) = F_layer(k) !/(h_vel(k) + CS%H_subroundoff) + write(*,*)'F_layer(k), h_vel(k)',F_layer(k), h_vel(k) enddo ! deallocated arrays @@ -823,312 +717,9 @@ subroutine fluxes_layer_method2(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) -end subroutine fluxes_layer_method2 - -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method1 -subroutine fluxes_layer_method1(boundary, nk, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - khtr_u, F_layer, CS) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers in the local z-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, 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] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t - !! at a velocity point [L2 ~> m2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local - !! z-grid [H L2 conc ~> m3 conc] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure - !! the boundary layer - ! Local variables - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] - !! This is just to remind developers that khtr_avg should be - !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses - !! [H-1 ~> m-1 or m2 kg-1] - real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] - real :: htot !< Total column thickness [H ~> m or kg m-2] - !real :: heff_tot !< Total effective column thickness in the transition layer [m] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively - integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively - integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively - 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 :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] - 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] - - F_layer(:) = 0.0 - if (hbl_L == 0. .or. hbl_R == 0.) then - return - endif - - ! Calculate vertical indices containing the boundary layer in dz_top - call boundary_k_range(boundary, nk, CS%dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, CS%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) - - ! make sure left and right k indices span same range - if (k_bot_min .ne. k_bot_L) then - k_bot_L = k_bot_min - zeta_bot_L = 1.0 - endif - if (k_bot_min .ne. k_bot_R) then - k_bot_R= k_bot_min - zeta_bot_R = 1.0 - endif - - h_work_L = (CS%dz_top(k_bot_L) * zeta_bot_L) - h_work_R = (CS%dz_top(k_bot_R) * zeta_bot_R) - - ! GMM, the following needs to be modified. We need to calculate ppoly0_E_L and ppoly0_coefs_L here... - !phi_L_avg = average_value_ppoly( nk, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) - !phi_R_avg = average_value_ppoly( nk, phi_R_local, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) - !heff = harmonic_mean(h_work_L, h_work_R) - - ! tracer flux where the minimum BLD intersets layer - ! GMM, khtr_avg should be computed once khtr is 3D - if ((CS%linear) .and. (k_bot_diff .gt. 1)) then - ! apply linear decay at the base of hbl - do k = k_bot_min-1,1,-1 - !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) - enddo - htot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 - htot = htot + CS%dz_top(k) - enddo - - a = -1.0/htot - htot = 0.0 - do k = k_bot_min,k_bot_max, 1 - !heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) * wgt - htot = htot + CS%dz_top(k) - enddo - else - !!F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) - do k = k_bot_min-1,1,-1 - !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R(k) - phi_L(k)) - enddo - endif - endif - -! 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 .ne. k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max .ne. k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! h_work_L = (CS%dz_bot(k_top_L) * zeta_top_L) -! h_work_R = (CS%dz_bot(k_top_R) * zeta_top_R) -! -! phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, 1.0-zeta_top_L, 1.0) -! phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) -! heff = harmonic_mean(h_work_L, h_work_R) -! -! ! 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 -! heff = harmonic_mean(h_L(k), h_R(k)) -! F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) -! enddo -! endif - -end subroutine fluxes_layer_method1 - -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method1 -subroutine fluxes_layer_method(boundary, nk, nk_z, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & - F_layer, CS) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers in the native grid [nondim] - integer, intent(in ) :: nk_z !< Number of layers in the local z-grid [nondim] - integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] - 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, 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] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t - !! at a velocity point [L2 ~> m2] - real, dimension(nk_z), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point in the local - !! z-grid [H L2 conc ~> m3 conc] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure - !! the boundary layer - ! Local variables - real, dimension(nk_z) :: phi_L_local !< Tracer values (left) in the zgrid [conc] - real, dimension(nk_z) :: phi_R_local !< Tracer values (right) in the zgrid [conc] - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] - !! This is just to remind developers that khtr_avg should be - !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses - !! [H-1 ~> m-1 or m2 kg-1] - real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] - real :: htot !< Total column thickness [H ~> m or kg m-2] - !real :: heff_tot !< Total effective column thickness in the transition layer [m] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively - integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively - integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively - integer :: k_top_L, k_bot_L !< k-indices left native grid - integer :: k_top_R, k_bot_R !< k-indices right native grid - integer :: k_top_zgrid_L, k_bot_zgrid_L !< k-indices left zgrid - integer :: k_top_zgrid_R, k_bot_zgrid_R !< k-indices right zgrid - 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 :: zeta_top_zgrid_L, zeta_top_zgrid_R !< distance from the top of a layer to the boundary - !! layer depth in the zgrid [nondim] - real :: zeta_bot_zgrid_L, zeta_bot_zgrid_R !< distance from the bottom of a layer to the boundary - !!layer depth in the zgrid [nondim] - real :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] - 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] - - F_layer(:) = 0.0 - if (hbl_L == 0. .or. hbl_R == 0.) then - return - endif - - ! Calculate vertical indices containing the boundary layer in the zgrid - call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate vertical indices containing the boundary layer in dz_top - call boundary_k_range(boundary, nk_z, CS%dz_top, hbl_L, k_top_zgrid_L, zeta_top_zgrid_L, k_bot_zgrid_L, zeta_bot_zgrid_L) - call boundary_k_range(boundary, nk_z, CS%dz_top, hbl_R, k_top_zgrid_R, zeta_top_zgrid_R, k_bot_zgrid_R, zeta_bot_zgrid_R) - - call remapping_core_h(CS%remap_cs, nk, h_L, phi_L, nk_z, CS%dz_top, phi_L_local) - call remapping_core_h(CS%remap_cs, nk, h_R, phi_R, nk_z, CS%dz_top, phi_R_local) - - if (boundary == SURFACE) then - k_bot_min = MIN(k_bot_zgrid_L, k_bot_zgrid_R) - k_bot_max = MAX(k_bot_zgrid_L, k_bot_zgrid_R) - k_bot_diff = (k_bot_max - k_bot_min) - - ! make sure left and right k indices span same range - if (k_bot_min .ne. k_bot_zgrid_L) then - k_bot_zgrid_L = k_bot_min - zeta_bot_zgrid_L = 1.0 - endif - if (k_bot_min .ne. k_bot_zgrid_R) then - k_bot_zgrid_R= k_bot_min - zeta_bot_zgrid_R = 1.0 - endif - - h_work_L = (CS%dz_top(k_bot_zgrid_L) * zeta_bot_zgrid_L) - h_work_R = (CS%dz_top(k_bot_zgrid_R) * zeta_bot_zgrid_R) - - ! GMM, the following needs to be modified. We need to calculate ppoly0_E_L and ppoly0_coefs_L here... - !phi_L_avg = average_value_ppoly( nk_z, phi_L_local, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) - !phi_R_avg = average_value_ppoly( nk_z, phi_R_local, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) - !heff = harmonic_mean(h_work_L, h_work_R) - - ! tracer flux where the minimum BLD intersets layer - ! GMM, khtr_avg should be computed once khtr is 3D - if ((CS%linear) .and. (k_bot_diff .gt. 1)) then - ! apply linear decay at the base of hbl - do k = k_bot_min-1,1,-1 - !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) - enddo - htot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 - htot = htot + CS%dz_top(k) - enddo - - a = -1.0/htot - htot = 0.0 - do k = k_bot_min,k_bot_max, 1 - !heff = harmonic_mean(h_L(k), h_R(k)) - wgt = (a*(htot + (CS%dz_top(k) * 0.5))) + 1.0 - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) * wgt - htot = htot + CS%dz_top(k) - enddo - else - F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) - do k = k_bot_min-1,1,-1 - !heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(CS%dz_top(k) * khtr_u) * (phi_R_local(k) - phi_L_local(k)) - enddo - endif - endif - - 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 .ne. k_top_L) then - k_top_L = k_top_max - zeta_top_L = 1.0 - endif - if (k_top_max .ne. k_top_R) then - k_top_R= k_top_max - zeta_top_R = 1.0 - endif - - h_work_L = (h_L(k_top_L) * zeta_top_L) - h_work_R = (h_R(k_top_R) * zeta_top_R) - - phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, 1.0-zeta_top_L, 1.0) - phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) - heff = harmonic_mean(h_work_L, h_work_R) - - ! 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 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - enddo - endif 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 @@ -1161,6 +752,17 @@ logical function near_boundary_unit_tests( verbose ) integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position real :: area_L,area_R ! Area of grid cell [m^2] + 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=.true. + area_L = 1.; area_R = 1. ! Set to unity for all unit tests near_boundary_unit_tests = .false. @@ -1238,55 +840,55 @@ logical function near_boundary_unit_tests( verbose ) ! 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, h1) + 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+1, test_name, h1, (/1., 0.5, 1.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, h1) + 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+2, test_name, h1, (/0.5, 0.5, 0.5, 1.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, h1) + 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+2, test_name, h1, (/1., 0.5, 0.5, 2./) ) 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, h1) + 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+3, test_name, h1, (/0.5, 0.5, 0.5, 0.5, 2./) ) 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, 1.0, h1) + call merge_interfaces(nk, (/2., 3./), (/2., 2./), 1.0, 1.0, CS%H_subroundoff, h1) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., 2., 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, h1) + 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, test_name, h1, (/2., 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, h1) + 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+1, test_name, h1, (/1., 1., 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./), 2.0, 2.0, h1) + 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, test_name, h1, (/2., 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, h1) + 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+1, test_name, h1, (/1., 1., 2./) ) deallocate(h1) @@ -1295,214 +897,68 @@ logical function near_boundary_unit_tests( verbose ) ! 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 = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) + hbl_L = 2.; hbl_R = 2. + h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - ! Without limiter - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) - - !! same as above, but with limiter - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, .true.) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-1.0/) ) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 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 = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/0.,0./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 0.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. - ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (no gradient)' - hbl_L = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' - hbl_L = 16.; hbl_R = 16. - h_L = (/10.,6./) ; h_R = (/6.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' - hbl_L = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,0./) ; phi_R = (/0.,1./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - - ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) - - test_name = 'hbl < column thickness, hbl same, constant concentration each column' - hbl_L = 2; hbl_R = 2 - h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) - - test_name = 'hbl < column thickness, hbl same, linear profile right' - hbl_L = 2; hbl_R = 2 - h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. - khtr_u = 1. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - !call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + 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, 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./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. khtr_u = 2. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - !call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-3./) ) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-3.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, CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) - ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 h_L = (/6.,6./) ; h_R = (/10.,10./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - !call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, CS) !near_boundary_unit_tests = near_boundary_unit_tests .or. & ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - test_name = 'Different hbl and different column thicknesses (linear profile right)' - - hbl_L = 15; hbl_R = 6 - h_L = (/10.,10./) ; h_R = (/12.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,3./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 2. - phi_pp_R(2,1) = 2.; phi_pp_R(2,2) = 2. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 2. - ppoly0_E_R(2,1) = 2.; ppoly0_E_R(2,2) = 4. + 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, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & - ! phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed fluxes_layer_method' + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 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 @@ -1581,7 +1037,7 @@ end function test_boundary_k_range !! !! Boundary lateral diffusion can be applied using one of the three methods: !! -!! * [Method #1: Along layer](@ref section_method2) (default); +!! * [Method #1: Along layer](@ref section_method) (default); !! * [Method #2: Bulk layer](@ref section_method1); !! !! A brief summary of these methods is provided below. From 4ab4a7af75a5d15513174c4ea34cedbb7c22405d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Oct 2020 17:04:01 -0600 Subject: [PATCH 033/212] Remove hard-coded BLD and uncomment code for adv and PGF --- src/core/MOM.F90 | 4 ++-- src/core/MOM_dynamics_unsplit.F90 | 12 +++++------ src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 +++++------ src/tracer/MOM_neutral_diffusion.F90 | 20 +++++++++---------- 4 files changed, 22 insertions(+), 26 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index cf1f2fbe42..bf405dcd02 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1159,8 +1159,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) ! GMM, turn off advection -! call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & -! CS%tracer_adv_CSp, CS%tracer_Reg) + call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg) call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index fba05c8b17..f6f58911ad 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -313,8 +313,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) enddo ; enddo ; endif ! GMM, turn off pressure force -! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & -! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then @@ -380,8 +380,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) enddo ; enddo ; endif ! GMM, turn off pressure force -! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & -! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then @@ -456,8 +456,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! PFu = d/dx M(h_av,T,S) call cpu_clock_begin(id_clock_pres) ! GMM, turn off pressure force -! call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & -! CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 6f09de371d..d56ce7ff9e 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -112,9 +112,9 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, CS%surface_boundary_scheme = -1 !GMM, uncomment below -! 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 + 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, & @@ -183,10 +183,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real :: tmpReal, tmp1, tmp2 Idt = 1./dt - hbl(:,:) = 100. - hbl(4:6,:) = 500. - !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - !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, hbl, G) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) do m = 1,Reg%ntr diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 3a335c82d4..deb696f5f1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -228,13 +228,13 @@ logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diab default = .true.) endif -! if (CS%interior_only) then -! 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 -! call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") -! endif -! endif + if (CS%interior_only) then + 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 + call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") + endif + endif ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 @@ -315,10 +315,8 @@ 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 - hbl(:,:) = 100. - hbl(4:6,:) = 500. - !if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - !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, hbl, G) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 From f444affd39a9eec1ba2927147ed221fd511dbd55 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Oct 2020 17:26:11 -0600 Subject: [PATCH 034/212] Comment out write statements --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d56ce7ff9e..b1f93b2768 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -191,7 +191,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! current tracer tracer => Reg%tr(m) call pass_var(tracer%t,G%Domain) - write(*,*)' ##### tracer name ######', tracer%name + !write(*,*)' ##### tracer name ######', tracer%name ! 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 @@ -404,13 +404,13 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) enddo endif - write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) + !write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) allocate(h(nk2-1)) do k=1,nk2-1 h(k) = (eta2(k+1) - eta2(k)) + H_subroundoff enddo - write(*,*)'h ',h(:) + !write(*,*)'h ',h(:) end subroutine merge_interfaces @@ -613,9 +613,9 @@ 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_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) - do k=1,nk - write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) - enddo + !do k=1,nk + ! write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) + !enddo if (CS%debug) then tmp1 = SUM(phi_L(:)*h_L(:)) @@ -696,9 +696,9 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! enddo ! endif - do k=1,nk - write(*,*)'F_layer_z(k)',F_layer_z(k) - enddo + !do k=1,nk + ! write(*,*)'F_layer_z(k)',F_layer_z(k) + !enddo do k = 1,ke h_vel(k) = harmonic_mean(h_L(k), h_R(k)) @@ -707,7 +707,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) do k = 1,ke F_layer(k) = F_layer(k) !/(h_vel(k) + CS%H_subroundoff) - write(*,*)'F_layer(k), h_vel(k)',F_layer(k), h_vel(k) + !write(*,*)'F_layer(k), h_vel(k)',F_layer(k), h_vel(k) enddo ! deallocated arrays From 2538c4d2afc64496aea5a5afb54281790b7b3223 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 15 Oct 2020 11:36:25 -0600 Subject: [PATCH 035/212] Improve the merging of interfaces * adding new functions to sort, swap, and remove duplications in 1D arrays * updating unit tests * clean the module --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 305 +++++++----------- 1 file changed, 121 insertions(+), 184 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index b1f93b2768..e07633674a 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -111,7 +111,6 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) CS%surface_boundary_scheme = -1 - !GMM, uncomment below 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 @@ -129,7 +128,7 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction = .true., check_remapping = .true.) + check_reconstruction = .false., check_remapping = .false.) 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.", & @@ -191,7 +190,6 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! current tracer tracer => Reg%tr(m) call pass_var(tracer%t,G%Domain) - !write(*,*)' ##### tracer name ######', tracer%name ! 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 @@ -318,6 +316,77 @@ real function harmonic_mean(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, e !< start and end indices + real, dimension(e), intent(in) :: x !< 1D array to be checked + + ! local variables + integer :: 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, b !< values to be swaped + + ! local variables + integer :: 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) + real, dimension(n), intent(inout) :: x !< 1D array to be sorted + integer, intent(in ) :: n !< # of pts in the array + + ! 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) + 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 + + ! local variables + real, dimension(n) :: tmp + integer :: i + real :: min_val, max_val + + tmp(:) = 0. + min_val = minval(val)-1 + max_val = maxval(val) + i = 0 + do while (min_valmin_val) + tmp(i) = min_val + enddo + 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 @@ -334,154 +403,44 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) real, dimension(:), allocatable, intent(inout) :: h !< Combined thicknesses [H ~> m or kg m-2] ! Local variables - real, dimension(nk+1) :: eta_L, eta_R !< Interfaces in the left and right coloumns - real, dimension(:), allocatable :: eta1 !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R - real, dimension(:), allocatable :: eta2 !< Combined interfaces (eta1), plus hbl_L and hbl_R - integer :: k, nk1, nk2 - logical :: add_hbl_L, add_hbl_R - - add_hbl_L = .true.; add_hbl_R = .true. - - ! compute interfaces - eta_L(:) = 0.0; eta_R(:) = 0.0 + 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 + 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 - ! build array with interfaces from eta_L and eta_R - allocate(eta1(1)) - eta1(1) = 0.0 - do k=2,nk+1 - if (eta_L(k) == eta_R(k)) then - ! add just one of them - if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) - elseif (eta_L(k) > eta_R(k)) then - ! add eta_R first - if (eta_R(k) /= eta_R(k-1)) call add_to_list(eta1, eta_R(k)) - if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) - else - ! add eta_L first - if (eta_L(k) /= eta_L(k-1)) call add_to_list(eta1, eta_L(k)) - if (eta_R(k) /= eta_R(k-1)) call add_to_list(eta1, eta_R(k)) - endif - enddo + ! add hbl_L and hbl_R into eta_all + eta_all(kk+2) = hbl_L + eta_all(kk+3) = hbl_R - !write(*,*)'eta1, SIZE(eta1)',eta1(:), SIZE(eta1) - ! check if hbl_L and hbl_R exist in eta1. If not, add them. - nk1 = SIZE(eta1) + ! sort eta_all + call sort(eta_all, n) - do k=1,nk1 - if (eta1(k) == hbl_L) add_hbl_L = .false. - if (eta1(k) == hbl_R) add_hbl_R = .false. - enddo - if (hbl_L == hbl_R) then - ! only add hbl_L - add_hbl_R = .false. - endif + ! remove duplicates from eta_all + call unique(eta_all, n, eta_unique) - if (add_hbl_L .and. add_hbl_R) then - ! add both hbl_L and hbl_R - nk2 = nk1 + 2 - allocate(eta2(nk2)) - call add_two_interfaces(nk1, eta1, hbl_L, hbl_R, eta2) - elseif (add_hbl_L) then - ! only add hbl_L - nk2 = nk1 + 1 - allocate(eta2(nk2)) - call add_one_interface(nk1, eta1, hbl_L, eta2) - elseif (add_hbl_R) then - ! only add hbl_R - nk2 = nk1 + 1 - allocate(eta2(nk2)) - call add_one_interface(nk1, eta1, hbl_R, eta2) - else - ! both hbl_L and hbl_R already exist - nk2 = nk1 - allocate(eta2(nk2)) - do k=1,nk2 - eta2(k) = eta1(k) - enddo - endif - - !write(*,*)'eta2, SIZE(eta2)',eta2(:), SIZE(eta2) - - allocate(h(nk2-1)) - do k=1,nk2-1 - h(k) = (eta2(k+1) - eta2(k)) + H_subroundoff + 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 - !write(*,*)'h ',h(:) end subroutine merge_interfaces -subroutine add_two_interfaces(nk, eta, val1, val2, new_eta) - integer, intent(in ) :: nk !< number of layers in eta - real, dimension(nk), intent(in ) :: eta !< intial interfaces - real, intent(in ) :: val1 !< first interface to be added - real, intent(in ) :: val2 !< second interface to be added - real, dimension(nk+2), intent(inout) :: new_eta !< final interfaces - - ! local variables - integer :: k, k_new - real, dimension(nk+1) :: eta_tmp - - call add_one_interface(nk, eta, val1, eta_tmp) - call add_one_interface(nk+1, eta_tmp, val2, new_eta) - -end subroutine add_two_interfaces - -subroutine add_one_interface(nk, eta, new_val, new_eta) - integer, intent(in ) :: nk !< number of layers in eta - real, dimension(nk), intent(in ) :: eta !< intial interfaces - real, intent(in ) :: new_val !< interface to be added - real, dimension(nk+1), intent(inout) :: new_eta !< final interfaces - - ! local variables - integer :: k, k_new - - new_eta(:) = 0.0 - k_new = 1 - do k=1,nk-1 - if ((new_val > eta(k)) .and. (new_val < eta(k+1))) then - new_eta(k_new) = eta(k) - new_eta(k_new+1) = new_val - k_new = k_new + 2 - else - new_eta(k_new) = eta(k) - k_new = k_new + 1 - endif - enddo - new_eta(nk+1) = eta(nk) - -end subroutine add_one_interface - -subroutine add_to_list(list, element) - real, intent(in) :: element - real, dimension(:), allocatable, intent(inout) :: list - - ! local variables - integer :: i, isize - real, dimension(:), allocatable :: clist - - - if(allocated(list)) then - isize = size(list) - allocate(clist(isize+1)) - do i=1,isize - clist(i) = list(i) - end do - clist(isize+1) = element - - deallocate(list) - call move_alloc(clist, list) - - else - allocate(list(1)) - list(1) = element - end if - -end subroutine add_to_list - !> 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] @@ -613,10 +572,6 @@ 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_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) - !do k=1,nk - ! write(*,*)'dz_top(k), phi_L_z(k)-phi_R_z(k)',dz_top(k), (phi_L_z(k)-phi_R_z(k)) - !enddo - if (CS%debug) then tmp1 = SUM(phi_L(:)*h_L(:)) tmp2 = SUM(phi_L_z(:)*dz_top(:)) @@ -696,10 +651,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! enddo ! endif - !do k=1,nk - ! write(*,*)'F_layer_z(k)',F_layer_z(k) - !enddo - do k = 1,ke h_vel(k) = harmonic_mean(h_L(k), h_R(k)) enddo @@ -707,7 +658,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) do k = 1,ke F_layer(k) = F_layer(k) !/(h_vel(k) + CS%H_subroundoff) - !write(*,*)'F_layer(k), h_vel(k)',F_layer(k), h_vel(k) enddo ! deallocated arrays @@ -724,32 +674,18 @@ logical function near_boundary_unit_tests( verbose ) ! Local variables integer, parameter :: nk = 2 ! Number of layers - integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) - integer, parameter :: method = 1 ! Method used for integrating polynomials - real, dimension(nk+2) :: eta1 ! Updated interfaces with one extra value [m] - real, dimension(nk+3) :: eta2 ! Updated interfaces with two extra values [m] + 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) [ nondim m^-3 ] - real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - real, dimension(nk,deg+1) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions - ! [ nondim m^-3 ] - - real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] real :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] - real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] - real :: h_u, hblt_u ! Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-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 integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position - real :: area_L,area_R ! Area of grid cell [m^2] type(lbd_CS), pointer :: CS allocate(CS) @@ -759,9 +695,7 @@ logical function near_boundary_unit_tests( verbose ) 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=.true. - - area_L = 1.; area_R = 1. ! Set to unity for all unit tests + CS%debug=.false. near_boundary_unit_tests = .false. write(stdout,*) '==== MOM_lateral_boundary_diffusion =======================' @@ -823,18 +757,20 @@ logical function near_boundary_unit_tests( verbose ) if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed boundary_k_range' - ! unit tests for adding interfaces - test_name = 'Add one interface' - call add_one_interface(nk+1, (/0., 2., 4./), 1., eta1) + ! 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+2, test_name, eta1, (/0., 1., 2., 4./) ) + test_layer_fluxes( verbose, nk+1, test_name, eta1, (/0., 0.1, 1./) ) - test_name = 'Add two interfaces' - call add_two_interfaces(nk+1, (/0., 2., 4./), 1., 3., eta2) + 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+3, test_name, eta2, (/0., 1., 2., 3., 4./) ) + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) + deallocate(h1) - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed add interfaces' + 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' @@ -891,6 +827,17 @@ logical function near_boundary_unit_tests( verbose ) test_layer_fluxes( verbose, nk+1, test_name, h1, (/1., 1., 2./) ) 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./), 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., 2., 1./) ) + 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/), 2.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+5, test_name, h1, (/1., 1., .5, .5, 1., 1., 1./) ) + 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 @@ -934,16 +881,6 @@ logical function near_boundary_unit_tests( verbose ) 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 right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - 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, CS) - !near_boundary_unit_tests = near_boundary_unit_tests .or. & - ! test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - test_name = 'Different hbl and different column thicknesses (gradient from left to right)' hbl_L = 15; hbl_R = 10. From 87ba533e42ad473a6a069efb59a7af7691015754 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 15 Oct 2020 11:39:40 -0600 Subject: [PATCH 036/212] Adds missing args for KPP_get_BLD and energetic_PBL_get_MLD --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index e07633674a..ad687acda4 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -182,8 +182,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real :: tmpReal, tmp1, tmp2 Idt = 1./dt - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - 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, 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 From f0face43f8a05b830d9dcff3d1c7ca4a4e924542 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 15 Oct 2020 14:15:56 -0600 Subject: [PATCH 037/212] Adds missing args for KPP_get_BLD and energetic_PBL_get_MLD --- src/tracer/MOM_neutral_diffusion.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index deb696f5f1..11990221b6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -315,8 +315,9 @@ 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) - 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, 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) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 From a962325d8b7f0a06f10f4b22c19c6a239c45aafd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 19 Oct 2020 14:53:22 -0600 Subject: [PATCH 038/212] Add option to apply flux limiter --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 101 +++++++++++++----- 1 file changed, 72 insertions(+), 29 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index ad687acda4..1e2584cb29 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -47,6 +47,7 @@ module MOM_lateral_boundary_diffusion 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 (default is true). 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 @@ -119,6 +120,8 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, 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 to the LBD.", default=.true.) call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -209,7 +212,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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,:), CS) + Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) endif enddo enddo @@ -218,7 +221,7 @@ subroutine lateral_boundary_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,:), CS) + Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) endif enddo enddo @@ -442,6 +445,34 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) 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 + real, intent(in ) :: area_L, area_R !< Area of left and right cells [H ~> m or kg m-2] + real, intent(in ) :: h_L, h_R !< Thickness of left and right cells [H ~> m or kg m-2] + real, intent(in ) :: phi_L, phi_R !< Tracer concentration in the left and right cells + + ! 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_R))) + + ! 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 +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] @@ -510,23 +541,25 @@ 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, 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 delta t - !! 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] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure + 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 delta t + !! 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 !! the boundary layer ! Local variables real, dimension(:), allocatable :: dz_top @@ -560,8 +593,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ endif ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - !allocate(dz_top(1000)); dz_top(:) = 0.5 + !call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) + allocate(dz_top(50)); dz_top(:) = 10.0 nk = SIZE(dz_top) ! allocate arrays @@ -611,6 +644,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter) 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 @@ -623,10 +658,14 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ 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) 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) 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 @@ -657,9 +696,12 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! remap flux to native grid call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) - do k = 1,ke - F_layer(k) = F_layer(k) !/(h_vel(k) + CS%H_subroundoff) - enddo + if (CS%limiter) then + do k = 1,ke + call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), & + phi_R(k), h_L(k), h_R(k)) + enddo + endif ! deallocated arrays deallocate(dz_top) @@ -697,6 +739,7 @@ logical function near_boundary_unit_tests( verbose ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. + CS%limiter=.false. near_boundary_unit_tests = .false. write(stdout,*) '==== MOM_lateral_boundary_diffusion =======================' @@ -848,7 +891,7 @@ logical function near_boundary_unit_tests( verbose ) 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, CS) + 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/) ) @@ -858,7 +901,7 @@ logical function near_boundary_unit_tests( verbose ) 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, CS) + 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/) ) @@ -868,7 +911,7 @@ logical function near_boundary_unit_tests( verbose ) 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, CS) + 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,-3.0/) ) @@ -878,7 +921,7 @@ logical function near_boundary_unit_tests( verbose ) 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, CS) + 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./) ) @@ -889,7 +932,7 @@ logical function near_boundary_unit_tests( verbose ) 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, CS) + 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/) ) From 9e7b0897398287ac73c0bf585172e3cd6ddc1431 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 19 Oct 2020 20:09:56 -0600 Subject: [PATCH 039/212] Improve flux limiter --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 47 ++++++++++--------- 1 file changed, 26 insertions(+), 21 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 1e2584cb29..3d7ac1e553 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -463,13 +463,17 @@ subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) ! 0 1 0 .2.2.2 ! 0 .2 ! - F_max = -0.2 * ((area_R*(phi_R*h_R))-(area_L*(phi_L*h_R))) + F_max = -0.2 * ((area_R*(phi_R*h_R))-(area_L*(phi_L*h_L))) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer = MIN(F_layer,F_max) + 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 = MAX(F_layer,F_max) + F_layer = 0.0 endif end subroutine flux_limiter @@ -593,8 +597,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ endif ! Define vertical grid, dz_top - !call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - allocate(dz_top(50)); dz_top(:) = 10.0 + call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) + !allocate(dz_top(100)); dz_top(:) = 5.0 nk = SIZE(dz_top) ! allocate arrays @@ -606,18 +610,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_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) - if (CS%debug) then - tmp1 = SUM(phi_L(:)*h_L(:)) - tmp2 = SUM(phi_L_z(:)*dz_top(:)) - call sum_across_PEs(tmp1) - call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total tracer, native and z (L):', tmp1, tmp2 - tmp1 = SUM(phi_R(:)*h_R(:)) - tmp2 = SUM(phi_R_z(:)*dz_top(:)) - call sum_across_PEs(tmp1) - call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total tracer, native and z (R):', tmp1, tmp2 - endif + !if (CS%debug) then + ! tmp1 = SUM(phi_L(:)*h_L(:)) + ! tmp2 = SUM(phi_L_z(:)*dz_top(:)) + ! call sum_across_PEs(tmp1) + ! call sum_across_PEs(tmp2) + ! if (is_root_pe()) write(*,*)'Total tracer, native and z (L):', tmp1, tmp2 + ! tmp1 = SUM(phi_R(:)*h_R(:)) + ! tmp2 = SUM(phi_R_z(:)*dz_top(:)) + ! call sum_across_PEs(tmp1) + ! call sum_across_PEs(tmp2) + ! if (is_root_pe()) write(*,*)'Total tracer, native and z (R):', tmp1, tmp2 + !endif ! 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) @@ -698,8 +702,9 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) if (CS%limiter) then do k = 1,ke - call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), & - phi_R(k), h_L(k), h_R(k)) + if (F_layer(k) /= 0.) call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), & + phi_R(k), h_L(k), h_R(k)) + !F_layer(k) = 0. enddo endif From e484bc87ae0bcff37c3b096aa1a760448f3f5ecd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 20 Oct 2020 15:32:54 -0600 Subject: [PATCH 040/212] Add option to set maximum value in subrotine unique * Fix a few bugs in find_minimum and swap (int to real) --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 57 +++++++++++++------ 1 file changed, 40 insertions(+), 17 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 3d7ac1e553..ee88e5e439 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -131,7 +131,7 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction = .false., check_remapping = .false.) + check_reconstruction = .false., check_remapping = .false., answers_2018 = .false.) 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.", & @@ -327,7 +327,7 @@ integer function find_minimum(x, s, e) real, dimension(e), intent(in) :: x !< 1D array to be checked ! local variables - integer :: minimum + real :: minimum integer :: location integer :: i @@ -347,7 +347,7 @@ subroutine swap(a, b) real, intent(inout) :: a, b !< values to be swaped ! local variables - integer :: tmp + real :: tmp tmp = a a = b b = tmp @@ -368,25 +368,42 @@ subroutine sort(x, n) end subroutine sort !> Returns the unique values in a 1D array. -subroutine unique(val, n, val_unique) - 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 - +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 + 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) + min_val = MINVAL(val)-1 + max_val = MAXVAL(val) i = 0 do while (min_valmin_val) + min_val = MINVAL(val, mask=val>min_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 @@ -411,11 +428,11 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) 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 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 @@ -431,18 +448,21 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) eta_all(kk+2) = hbl_L eta_all(kk+3) = hbl_R + ! find the minimum depth + min_depth = MIN(MAXVAL(eta_L), MAXVAL(eta_R)) + !if (is_root_pe()) write(*,*)'min_depth, MAXVAL(eta_L), MAXVAL(eta_R)', min_depth, MAXVAL(eta_L), MAXVAL(eta_R) ! sort eta_all call sort(eta_all, n) - - ! remove duplicates from eta_all - call unique(eta_all, n, eta_unique) + !if (is_root_pe()) write(*,*)'eta_all',eta_all(:) + ! remove duplicates from eta_all and sets maximum depth + call unique(eta_all, n, eta_unique, min_depth) + !if (is_root_pe()) write(*,*)'eta_unique',eta_unique(:) 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 @@ -610,6 +630,9 @@ 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_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) + !if (is_root_pe()) write(*,*)'dz_top',dz_top(:) + !if (is_root_pe()) write(*,*)'phi_L',phi_L(:) + !if (is_root_pe()) write(*,*)'phi_L_z',phi_L_z(:) !if (CS%debug) then ! tmp1 = SUM(phi_L(:)*h_L(:)) ! tmp2 = SUM(phi_L_z(:)*dz_top(:)) From 9fb6f75270c12c7a20b4405e329c637369ea4b08 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 20 Oct 2020 15:42:40 -0600 Subject: [PATCH 041/212] Fix unit tests --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index ee88e5e439..9afbde41d3 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -872,7 +872,7 @@ logical function near_boundary_unit_tests( verbose ) 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, 1.0, CS%H_subroundoff, h1) near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., 2., 1./) ) + test_layer_fluxes( verbose, nk+1, test_name, h1, (/1., 1., 2./) ) deallocate(h1) test_name = 'Left has zero thickness, h_L /= h_R and BLD_L = BLD_R' @@ -900,15 +900,15 @@ logical function near_boundary_unit_tests( verbose ) 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./), 2.0, 2.0, CS%H_subroundoff, h1) + call merge_interfaces(nk+1, (/2., 2., 0./), (/2., 2., 1./), 2., 2., CS%H_subroundoff, h1) near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, h1, (/2., 2., 1./) ) + 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/), 2.0, 2.0, CS%H_subroundoff, h1) + call merge_interfaces(nk+2, (/2., 2., 1., 1./), (/1., 1., .5, .5/), 2., 2., CS%H_subroundoff, h1) near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+5, test_name, h1, (/1., 1., .5, .5, 1., 1., 1./) ) + 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' From 60559ecc12edde1ea963f1958ba83ed6b30855c7 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 20 Oct 2020 16:55:49 -0600 Subject: [PATCH 042/212] Code cleaning --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 89 ++++++------------- 1 file changed, 26 insertions(+), 63 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 9afbde41d3..38f7bc9df5 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -7,7 +7,7 @@ module MOM_lateral_boundary_diffusion 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_checksums, only : hchksum_pair, hchksum +use MOM_checksums, only : hchksum use MOM_domains, only : pass_var, sum_across_PEs use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field @@ -139,10 +139,7 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. -!! Two different methods are available: -!! Method 1: more straight forward, diffusion is applied layer by layer using only information -!! from neighboring cells. -!! Method 2: lower order representation, calculate fluxes from bulk layer integrated quantities. +!! Diffusion is applied layer by layer using only information from neighboring cells. 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 @@ -161,44 +158,40 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] - !real, dimension(SZIB_(G),SZJ_(G),CS%nk) :: uFlx !< Zonal flux of tracer in z-space [conc m^3] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] - !real, dimension(SZI_(G),SZJB_(G),CS%nk) :: vFlx !< Meridional flux of tracer in z-space [conc m^3] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic -! real, dimension(SZI_(G),SZJ_(G),CS%nk) :: tracer_z !< Tracer in the zgrid 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(SZK_(GV)) :: tracer_1d !< 1d-array used to remap tracer change to native grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, !! only used to compute tendencies. -! real, dimension(SZI_(G),SZJ_(G),CS%nk) :: diff_z !< Used to store difference in tracer concentration in -! !! z-space after applying diffusion. real, dimension(SZI_(G),SZJ_(G)) :: tracer_int, tracer_end !< integrated tracer in the native grid, before and after ! LBD is applied. integer :: remap_method !< Reconstruction method integer :: i, j, k, m !< indices to loop over real :: Idt !< inverse of the time step [s-1] - real :: tmpReal, tmp1, tmp2 + real :: tmpReal, tmp1, tmp2 !< temporary variables 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) - call pass_var(tracer%t,G%Domain) + + 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(:,:,:) = 0.0 tracer_old(:,:,:) = tracer%t(:,:,:) endif @@ -231,10 +224,14 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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) = (tracer%t(i,j,k)-tracer_old(i,j,k)) * Idt + endif endif enddo ; enddo ; enddo if (CS%debug) then + call hchksum(tracer%t, "after LBD "//tracer%name,G%HI) tracer_int(:,:) = 0.0; tracer_end(:,:) = 0.0 ! tracer (native grid) before and after LBD do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -250,13 +247,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) tmp2 = SUM(tracer_end) call sum_across_PEs(tmp1) call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total tracer, before/after:', tmp1, tmp2 - endif - - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then - do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - tendency(i,j,k) = (tracer%t(i,j,k)-tracer_old(i,j,k)) * Idt - enddo ; enddo ; enddo + if (is_root_pe()) write(*,*)'Total '//tracer%name//' before/after:', tmp1, tmp2 endif ! Post the tracer diagnostics @@ -450,13 +441,10 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) ! find the minimum depth min_depth = MIN(MAXVAL(eta_L), MAXVAL(eta_R)) - !if (is_root_pe()) write(*,*)'min_depth, MAXVAL(eta_L), MAXVAL(eta_R)', min_depth, MAXVAL(eta_L), MAXVAL(eta_R) ! sort eta_all call sort(eta_all, n) - !if (is_root_pe()) write(*,*)'eta_all',eta_all(:) ! remove duplicates from eta_all and sets maximum depth call unique(eta_all, n, eta_unique, min_depth) - !if (is_root_pe()) write(*,*)'eta_unique',eta_unique(:) nk1 = SIZE(eta_unique) allocate(h(nk1-1)) @@ -468,11 +456,11 @@ 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 - real, intent(in ) :: area_L, area_R !< Area of left and right cells [H ~> m or kg m-2] - real, intent(in ) :: h_L, h_R !< Thickness of left and right cells [H ~> m or kg m-2] + real, intent(inout) :: F_layer !< Tracer flux to be checked [H L2 conc ~> m3 conc] + real, intent(in ) :: area_L, area_R !< Area of left and right cells [L2 ~> m2] + real, intent(in ) :: h_L, h_R !< Thickness of left and right cells [H ~> m or kg m-2] real, intent(in ) :: phi_L, phi_R !< Tracer concentration in the left and right cells + !! [conc] ! local variables real :: F_max !< maximum flux allowed @@ -630,22 +618,6 @@ 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_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) - !if (is_root_pe()) write(*,*)'dz_top',dz_top(:) - !if (is_root_pe()) write(*,*)'phi_L',phi_L(:) - !if (is_root_pe()) write(*,*)'phi_L_z',phi_L_z(:) - !if (CS%debug) then - ! tmp1 = SUM(phi_L(:)*h_L(:)) - ! tmp2 = SUM(phi_L_z(:)*dz_top(:)) - ! call sum_across_PEs(tmp1) - ! call sum_across_PEs(tmp2) - ! if (is_root_pe()) write(*,*)'Total tracer, native and z (L):', tmp1, tmp2 - ! tmp1 = SUM(phi_R(:)*h_R(:)) - ! tmp2 = SUM(phi_R_z(:)*dz_top(:)) - ! call sum_across_PEs(tmp1) - ! call sum_across_PEs(tmp2) - ! if (is_root_pe()) write(*,*)'Total tracer, native and z (R):', tmp1, tmp2 - !endif - ! 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) @@ -655,24 +627,14 @@ 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) - ! make sure left and right k indices span same range - if (k_bot_min .ne. k_bot_L) then - k_bot_L = k_bot_min - zeta_bot_L = 1.0 - endif - if (k_bot_min .ne. k_bot_R) then - k_bot_R= k_bot_min - zeta_bot_R = 1.0 - endif - ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D if ((CS%linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - if (CS%limiter) 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)) + !if (CS%limiter) 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 @@ -685,18 +647,19 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ 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) 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)) + !if (CS%limiter) 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) 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)) + !if (CS%limiter) 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) @@ -723,11 +686,11 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! remap flux to native grid call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + ! apply flux_limiter in the native grid if (CS%limiter) then do k = 1,ke if (F_layer(k) /= 0.) call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), & phi_R(k), h_L(k), h_R(k)) - !F_layer(k) = 0. enddo endif From 300b6e9cf86cc0c5a2c649ac5eae2ab12da7e3b3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 20 Oct 2020 17:43:42 -0600 Subject: [PATCH 043/212] Option to apply limiter in native and LBD grids Adding an additional flag so the user can control if flux limiter should be applied in the native, LBD , or both grids. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 38f7bc9df5..8a4b7a4fc9 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -47,7 +47,10 @@ module MOM_lateral_boundary_diffusion 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 (default is true). + 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 @@ -121,7 +124,9 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, "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 to the LBD.", default=.true.) + "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.) @@ -633,8 +638,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! apply linear decay at the base of hbl do k = k_bot_min-1,1,-1 F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - !if (CS%limiter) 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)) + 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 @@ -647,14 +652,14 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ 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) 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)) + 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) 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)) + 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 From 30fac75c0ab8965598b530b56c341ded87e31d72 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 26 Oct 2020 23:45:56 -0600 Subject: [PATCH 044/212] introduce public module ints stdout and stderr for standard output --- src/framework/MOM_io.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index c516c96e86..d13dddc3c7 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -33,6 +33,7 @@ module MOM_io use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times use mpp_io_mod, only : io_infra_init=>mpp_io_init +use iso_fortran_env, only : stdout_iso=>output_unit, stderr_iso=>error_unit use netcdf implicit none ; private @@ -84,6 +85,9 @@ module MOM_io module procedure MOM_read_vector_2d end interface +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 From cc82d1154997cc779d17c75104114512acbadf3d Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 26 Oct 2020 23:49:51 -0600 Subject: [PATCH 045/212] use MOM_io::stdout in MCT cap instead of glb%stdout or FMS stdout --- config_src/mct_driver/mom_ocean_model_mct.F90 | 32 +++++------- .../mct_driver/mom_surface_forcing_mct.F90 | 52 +++++++++---------- config_src/mct_driver/ocn_comp_mct.F90 | 50 +++++++++--------- 3 files changed, 63 insertions(+), 71 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 2f94c9b7f9..5a04739971 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -56,7 +56,7 @@ module MOM_ocean_model_mct use coupler_types_mod, 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 mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init @@ -409,10 +409,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) - - if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' - call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -1053,20 +1049,18 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + integer :: n, m + + write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + write(stdout,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) + write(stdout,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) + write(stdout,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) + write(stdout,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) + write(stdout,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) + write(stdout,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) + write(stdout,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) + + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 92b5d148bb..82105e040e 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -34,10 +34,10 @@ module MOM_surface_forcing_mct use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn use coupler_types_mod, only : coupler_type_copy_data use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout use mpp_mod, only : mpp_chksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init +use MOM_io, only: stdout implicit none ; private @@ -1361,37 +1361,35 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(outunit,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(outunit,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ' , mpp_chksum( iobt%p ) + integer :: n,m + + write(stdout,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + write(stdout,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) + write(stdout,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) + write(stdout,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) + write(stdout,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) + write(stdout,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) + write(stdout,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) + write(stdout,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) + write(stdout,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) + write(stdout,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) + write(stdout,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) + write(stdout,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) + write(stdout,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) + write(stdout,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) + write(stdout,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) + write(stdout,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) + write(stdout,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) + write(stdout,100) 'iobt%p ' , mpp_chksum( iobt%p ) if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) + write(stdout,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) + write(stdout,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + write(stdout,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) 100 FORMAT(" CHECKSUM::",A20," = ",Z20) - call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + call coupler_type_write_chksums(iobt%fluxes, stdout, 'iobt%') end subroutine ice_ocn_bnd_type_chksum diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 741ce832e8..1872fff335 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -42,6 +42,7 @@ module ocn_comp_mct use MOM_constants, only: CELSIUS_KELVIN_OFFSET use MOM_domains, only: AGRID, BGRID_NE, CGRID_NE, pass_vector use mpp_domains_mod, only: mpp_get_compute_domain +use MOM_io, only: stdout ! Previously inlined - now in separate modules use MOM_ocean_model_mct, only: ocean_public_type, ocean_state_type @@ -88,7 +89,6 @@ module ocn_comp_mct type(cpl_indices_type) :: ind !< Variable IDs logical :: sw_decomp !< Controls whether shortwave is decomposed into 4 components real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition i/o - integer :: stdout !< standard output unit. (by default, points to ocn.log.* ) character(len=384) :: pointer_filename !< Name of the ascii file that contains the path !! and filename of the latest restart file. end type MCT_MOM_Data @@ -194,14 +194,14 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) call shr_file_getLogUnit (shrlogunit) call shr_file_getLogLevel(shrloglev) - glb%stdout = shr_file_getUnit() ! get an unused unit number + stdout = shr_file_getUnit() ! get an unused unit number ! open the ocn_modelio.nml file and then open a log file associated with stdout ocn_modelio_name = 'ocn_modelio.nml' // trim(inst_suffix) - call shr_file_setIO(ocn_modelio_name,glb%stdout) + call shr_file_setIO(ocn_modelio_name,stdout) ! set the shr log io unit number - call shr_file_setLogUnit(glb%stdout) + call shr_file_setLogUnit(stdout) end if call set_calendar_type(NOLEAP) !TODO: confirm this @@ -218,23 +218,23 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! Debugging clocks if (debug .and. is_root_pe()) then - write(glb%stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d + write(stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d endif npes = num_pes() @@ -298,7 +298,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! read name of restart file in the pointer file nu = shr_file_getUnit() restart_pointer_file = trim(glb%pointer_filename) - if (is_root_pe()) write(glb%stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + if (is_root_pe()) write(stdout,*) 'Reading ocn pointer file: ',restart_pointer_file restartfile = ""; restartfiles = ""; open(nu, file=restart_pointer_file, form='formatted', status='unknown') do @@ -316,13 +316,13 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) enddo close(nu) if (is_root_pe()) then - write(glb%stdout,*) 'Reading restart file(s): ',trim(restartfiles) + write(stdout,*) 'Reading restart file(s): ',trim(restartfiles) end if call shr_file_freeUnit(nu) call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles)) endif if (is_root_pe()) then - write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' end if ! Initialize ocn_state%sfc_state out of sight @@ -383,7 +383,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ncouple_per_day = seconds_in_day / ocn_cpl_dt mom_cpl_dt = seconds_in_day / ncouple_per_day if (mom_cpl_dt /= ocn_cpl_dt) then - write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' + write(stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' call exit(0) end if @@ -457,7 +457,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) if (is_root_pe()) then call shr_file_getLogUnit(shrlogunit) call shr_file_getLogLevel(shrloglev) - call shr_file_setLogUnit(glb%stdout) + call shr_file_setLogUnit(stdout) endif ! Query the beginning time of the current coupling interval @@ -484,7 +484,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) if (runtype /= "continue" .and. runtype /= "branch") then if (debug .and. is_root_pe()) then - write(glb%stdout,*) 'doubling first interval duration!' + write(stdout,*) 'doubling first interval duration!' endif ! shift back the start time by one coupling interval (to align the start time with other components) @@ -500,19 +500,19 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) if (debug .and. is_root_pe()) then call ESMF_ClockGet(EClock, CurrTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d + write(stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d endif ! set the cdata pointers: @@ -525,10 +525,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) !glb%sw_decomp = .false. !END TODO: if (glb%sw_decomp) then - call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock, & + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock, & c1=glb%c1, c2=glb%c2, c3=glb%c3, c4=glb%c4) else - call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock ) + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock ) end if ! Update internal ocean @@ -540,7 +540,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) !--- write out intermediate restart file when needed. ! Check alarms for flag to write restart at end of day write_restart_at_eod = seq_timemgr_RestartAlarmIsOn(EClock) - if (debug .and. is_root_pe()) write(glb%stdout,*) 'ocn_run_mct, write_restart_at_eod=', write_restart_at_eod + if (debug .and. is_root_pe()) write(stdout,*) 'ocn_run_mct, write_restart_at_eod=', write_restart_at_eod if (write_restart_at_eod) then ! case name @@ -575,7 +575,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) endif close(nu) - write(glb%stdout,*) 'ocn restart pointer file written: ',trim(restartname) + write(stdout,*) 'ocn restart pointer file written: ',trim(restartname) endif call shr_file_freeUnit(nu) @@ -761,7 +761,7 @@ end subroutine ocn_domain_mct else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then get_runtype = "branch" else - write(glb%stdout,*) 'ocn_comp_mct ERROR: unknown starttype' + write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' call exit(0) end if return From 1269874f2c430beb7b62e7c4e7cbfa7bbb4a71e1 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 27 Oct 2020 00:02:29 -0600 Subject: [PATCH 046/212] change all 'write(*,..' to 'write(stdout,...' --- src/ALE/MOM_remapping.F90 | 37 +++++++++---------- src/diagnostics/MOM_sum_output.F90 | 26 ++++++------- src/initialization/MOM_grid_initialize.F90 | 6 +-- .../MOM_shared_initialization.F90 | 12 +++--- 4 files changed, 40 insertions(+), 41 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 71ba83f3ba..1b3c5884de 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -13,8 +13,7 @@ module MOM_remapping 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 iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use MOM_io, only : stdout, stderr implicit none ; private @@ -1636,7 +1635,7 @@ logical function remapping_unit_tests(verbose) h_neglect = hNeglect_dflt h_neglect_edge = hNeglect_dflt ; if (answers_2018) h_neglect_edge = 1.0e-10 - write(*,*) '==== MOM_remapping: remapping_unit_tests =================' + write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false thisTest = .false. @@ -1645,19 +1644,19 @@ logical function remapping_unit_tests(verbose) err=x0(i)-0.75*real(i-1) if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. enddo - if (thisTest) write(*,*) 'remapping_unit_tests: Failed buildGridFromH() 1' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' remapping_unit_tests = remapping_unit_tests .or. thisTest call buildGridFromH(n1, h1, x1) do i=1,n1+1 err=x1(i)-real(i-1) if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. enddo - if (thisTest) write(*,*) 'remapping_unit_tests: Failed buildGridFromH() 2' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. call initialize_remapping(CS, 'PPM_H4', answers_2018=answers_2018) - if (verbose) write(*,*) 'h0 (test data)' + if (verbose) write(stdout,*) 'h0 (test data)' if (verbose) call dumpGrid(n0,h0,x0,u0) call dzFromH1H2( n0, h0, n1, h1, dx1 ) @@ -1666,9 +1665,9 @@ logical function remapping_unit_tests(verbose) err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. enddo - if (verbose) write(*,*) 'h1 (by projection)' + if (verbose) write(stdout,*) 'h1 (by projection)' if (verbose) call dumpGrid(n1,h1,x1,u1) - if (thisTest) write(*,*) 'remapping_unit_tests: Failed remapping_core_w()' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. @@ -1690,7 +1689,7 @@ logical function remapping_unit_tests(verbose) err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>2.*epsilon(err)) thisTest = .true. enddo - if (thisTest) write(*,*) 'remapping_unit_tests: Failed remapByProjection()' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByProjection()' remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. @@ -1698,14 +1697,14 @@ logical function remapping_unit_tests(verbose) call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, x1-x0(1:n1+1), & INTEGRATION_PPM, u1, hn1, h_neglect ) - if (verbose) write(*,*) 'h1 (by delta)' + 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(*,*) 'remapping_unit_tests: Failed remapByDeltaZ() 1' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 1' remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. @@ -1715,19 +1714,19 @@ logical function remapping_unit_tests(verbose) call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, dx2, & INTEGRATION_PPM, u2, hn2, h_neglect ) - if (verbose) write(*,*) 'h2' + if (verbose) write(stdout,*) 'h2' if (verbose) call dumpGrid(n2,h2,x2,u2) - if (verbose) write(*,*) 'hn2' + 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(*,*) 'remapping_unit_tests: Failed remapByDeltaZ() 2' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest - if (verbose) write(*,*) 'Via sub-cells' + if (verbose) write(stdout,*) 'Via sub-cells' thisTest = .false. call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) @@ -1737,7 +1736,7 @@ logical function remapping_unit_tests(verbose) err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) if (abs(err)>2.*epsilon(err)) thisTest = .true. enddo - if (thisTest) write(*,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & @@ -1748,9 +1747,9 @@ logical function remapping_unit_tests(verbose) 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(3,h2,x2,u2) - if (.not. remapping_unit_tests) write(*,*) 'Pass' + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' - write(*,*) '===== MOM_remapping: new remapping_unit_tests ==================' + write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) allocate(ppoly0_coefs(5,6)) @@ -1879,7 +1878,7 @@ logical function remapping_unit_tests(verbose) deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - if (.not. remapping_unit_tests) write(*,*) 'Pass' + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' end function remapping_unit_tests diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 2d4fb7e06f..e1b1b8efaf 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -12,7 +12,7 @@ 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, fieldtype, flush_file, open_file, reopen_file +use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file, stdout use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type @@ -827,11 +827,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ if (is_root_pe()) then if (CS%use_temperature) then - write(*,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & + write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & & ES18.12, ", Salt ", F15.11,", Temp ", F15.11)') & trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot, salin, temp else - write(*,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & + write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & & ES18.12)') & trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot endif @@ -853,39 +853,39 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif if (CS%ntrunc > 0) then - write(*,'(A," Energy/Mass:",ES12.5," Truncations ",I0)') & + write(stdout,'(A," Energy/Mass:",ES12.5," Truncations ",I0)') & trim(date_str), En_mass, CS%ntrunc endif if (CS%write_stocks) then - write(*,'(" Total Energy: ",Z16.16,ES24.16)') toten, toten - write(*,'(" Total Mass: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + write(stdout,'(" Total Energy: ",Z16.16,ES24.16)') toten, toten + write(stdout,'(" Total Mass: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & mass_tot, mass_chg, mass_anom, mass_anom/mass_tot if (CS%use_temperature) then if (Salt == 0.) then - write(*,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & + write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & Salt*0.001, Salt_chg*0.001, Salt_anom*0.001 else - write(*,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Salt*0.001, Salt_chg*0.001, Salt_anom*0.001, Salt_anom/Salt endif if (Heat == 0.) then - write(*,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & + write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & Heat, Heat_chg, Heat_anom else - write(*,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Heat, Heat_chg, Heat_anom, Heat_anom/Heat endif endif do m=1,nTr_stocks - write(*,'(" Total ",a,": ",ES24.16,X,a)') & + write(stdout,'(" Total ",a,": ",ES24.16,X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) if (Tr_minmax_got(m)) then - write(*,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) - write(*,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) endif diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 88130857c7..2c9445ae3e 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -14,7 +14,7 @@ module MOM_grid_initialize use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io, only : MOM_read_data, read_data, slasher, file_exists +use MOM_io, only : MOM_read_data, read_data, slasher, file_exists, stdout use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE use MOM_unit_scaling, only : unit_scale_type @@ -806,14 +806,14 @@ subroutine set_grid_metrics_mercator(G, param_file, US) y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2) G%gridLatB(J) = y_q*180.0/PI ! if (is_root_pe()) & - ! write(*, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2 + ! write(stdout, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2 enddo do j=G%jsg,G%jeg jd = fnRef + (j - jRef) - 0.5 y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1) G%gridLatT(j) = y_h*180.0/PI ! if (is_root_pe()) & - ! write(*, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1 + ! write(stdout, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1 enddo do J=JsdB+J_off,JedB+J_off jd = fnRef + (J - jRef) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 51676fb54d..7528f3f33e 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -11,7 +11,7 @@ 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, fieldtype, file_exists +use MOM_io, only : close_file, create_file, fieldtype, file_exists, stdout use MOM_io, only : MOM_read_data, MOM_read_vector, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, write_field, var_desc use MOM_string_functions, only : uppercase @@ -282,7 +282,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) j = jg(n) - G%jsd_global + 2 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then if (new_depth(n)/=0.) then - write(*,'(a,3i5,f8.2,a,f8.2,2i4)') & + write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)/m_to_Z,'->',abs(new_depth(n)),i,j D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else @@ -995,10 +995,10 @@ subroutine reset_face_lengths_list(G, param_file, US) G%dy_Cu(I,j) = G%mask2dCu(I,j) * m_to_L*min(L_to_m*G%dyCu(I,j), max(u_width(npt), 0.0)) 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 - write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& + write(stdout,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + write(stdout,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",L_to_m*G%dy_Cu(I,j),"m" endif @@ -1024,10 +1024,10 @@ subroutine reset_face_lengths_list(G, param_file, US) G%dx_Cv(i,J) = G%mask2dCv(i,J) * m_to_L*min(L_to_m*G%dxCv(i,J), max(v_width(npt), 0.0)) 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 - write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& + write(stdout,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + write(stdout,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",L_to_m*G%dx_Cv(I,j),"m" endif From 3f092914ef28fe2ea06a96160277a9222354e394 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 27 Oct 2020 10:55:55 -0600 Subject: [PATCH 047/212] replace iso_fortran_env::stdout with MOM_io::stdout --- src/framework/MOM_diag_vkernels.F90 | 2 +- src/framework/MOM_random.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 21 ++++++++----------- src/tracer/MOM_neutral_diffusion.F90 | 3 +-- 4 files changed, 12 insertions(+), 16 deletions(-) diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index b7c1130521..3d6e3e3f65 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -4,7 +4,7 @@ module MOM_diag_vkernels ! This file is part of MOM6. See LICENSE.md for the license. -use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use MOM_io, only : stdout, stderr implicit none ; private diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 14800df9aa..161236572c 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -11,7 +11,7 @@ module MOM_random use MersenneTwister_mod, only : getRandomReal ! Generates a random number use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer -use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use MOM_io, only : stdout, stderr implicit none ; private diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 465174f676..7281742fc4 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -23,7 +23,7 @@ module MOM_lateral_boundary_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 iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use MOM_io, only : stdout, stderr implicit none ; private @@ -1111,16 +1111,15 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] ! Local variables integer :: k - integer, parameter :: stdunit = stdout test_layer_fluxes = .false. do k=1,nk if ( F_calc(k) /= F_ans(k) ) then test_layer_fluxes = .true. - write(stdunit,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name - write(stdunit,10) k, F_calc(k), F_ans(k) + 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(stdunit,10) k, F_calc(k), F_ans(k) + write(stdout,10) k, F_calc(k), F_ans(k) endif enddo @@ -1141,19 +1140,17 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a character(len=80) :: test_name !< Name of the unit test logical :: verbose !< If true always print output - integer, parameter :: stdunit = stdout - test_boundary_k_range = k_top .ne. k_top_ans test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) test_boundary_k_range = test_boundary_k_range .or. (k_bot .ne. k_bot_ans) test_boundary_k_range = test_boundary_k_range .or. (zeta_bot .ne. zeta_bot_ans) - if (test_boundary_k_range) write(stdunit,*) "UNIT TEST FAILED: ", test_name + if (test_boundary_k_range) write(stdout,*) "UNIT TEST FAILED: ", test_name if (test_boundary_k_range .or. verbose) then - write(stdunit,20) "k_top", k_top, "k_top_ans", k_top_ans - write(stdunit,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans - write(stdunit,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans - write(stdunit,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans + 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,X,A,"=",i3) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 086caf390f..0bd2200d97 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -28,8 +28,7 @@ module MOM_neutral_diffusion 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 iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use MOM_io, only : stdout, stderr implicit none ; private From f5abc66b72ddde493c03716b86ae9c7ac6adc2e1 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Nov 2020 15:52:38 -0700 Subject: [PATCH 048/212] Fix bug in linear decay --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index c599f8bd3a..0dd551c066 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -637,19 +637,19 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! GMM, khtr_avg should be computed once khtr is 3D if ((CS%linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl - do k = k_bot_min-1,1,-1 + 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 + do k = k_bot_min,k_bot_max, 1 htot = htot + dz_top(k) enddo a = -1.0/htot - htot = 0.0 - do k = k_bot_min,k_bot_max, 1 + htot = dz_top(k_bot_min) + 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) From 11cc3dc5c25cbde8937c47e25cad995223a190f5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Nov 2020 16:51:33 -0700 Subject: [PATCH 049/212] Undo changes related to check_grid_def --- src/ALE/MOM_regridding.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 6dd775c9c4..2a77cb06fe 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -140,7 +140,7 @@ module MOM_regridding public getCoordinateUnits, getCoordinateShortName, getStaticThickness public DEFAULT_COORDINATE_MODE public get_zlike_CS, get_sigma_CS, get_rho_CS -public check_grid_def + !> Documentation for coordinate options character(len=*), parameter, public :: regriddingCoordinateModeDoc = & " LAYER - Isopycnal or stacked shallow water layers\n"//& diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 0dd551c066..10de28a653 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -21,7 +21,6 @@ module MOM_lateral_boundary_diffusion use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_remapping, only : remapping_core_h -use MOM_regridding, only : check_grid_def use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type From 48616d86aacc5aeb6d74c95594be8130562c1be5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Nov 2020 16:58:34 -0700 Subject: [PATCH 050/212] Delete uncessary comments --- src/core/MOM.F90 | 2 -- src/core/MOM_dynamics_unsplit.F90 | 3 --- 2 files changed, 5 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4a4c292e28..6930b2d4cb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1055,7 +1055,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE) else - ! GMM do nothing call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) @@ -1161,7 +1160,6 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) - ! GMM, turn off advection call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & CS%tracer_adv_CSp, CS%tracer_Reg) call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index d3448e6cc1..6b9aa8e759 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -312,7 +312,6 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) enddo ; enddo ; endif -! GMM, turn off pressure force call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) @@ -379,7 +378,6 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) enddo ; enddo ; endif -! GMM, turn off pressure force call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) @@ -455,7 +453,6 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! PFu = d/dx M(h_av,T,S) call cpu_clock_begin(id_clock_pres) -! GMM, turn off pressure force call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) From aa27f1c8e18edd4f9b15b61fdfee96733c89cb3a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Nov 2020 18:28:11 -0700 Subject: [PATCH 051/212] Add LBD clock, clean up, and document module * Adding a clock for LBD * Delete unecessary comments and clean up the code * Polish doxumentation --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 158 +++++++----------- 1 file changed, 59 insertions(+), 99 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 10de28a653..9db670c9a0 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -6,28 +6,24 @@ 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, CLOCK_ROUTINE +use MOM_cpu_clock, only : CLOCK_MODULE use MOM_checksums, only : hchksum use MOM_domains, only : pass_var, sum_across_PEs 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, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type, log_param -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_io, only : file_exists, field_size, MOM_read_data, slasher, field_exists +use MOM_error_handler, only : MOM_error, 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, build_reconstructions_1d -use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme -use MOM_remapping, only : remapping_core_h +use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme 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_string_functions, only : extract_integer, extract_real, extractWord use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -45,16 +41,16 @@ module MOM_lateral_boundary_diffusion 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. + !! 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. @@ -64,7 +60,8 @@ module MOM_lateral_boundary_diffusion ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module +character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module +integer :: id_clock_lbd !< CPU clock for lbd contains @@ -80,17 +77,10 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure ! local variables - character(len=80) :: string, varName ! Temporary strings - character(len=200) :: inputdir, fileName ! Temporary strings - character(len=320) :: message ! Temporary strings - character(len=12) :: expected_units ! Temporary strings - integer :: ke, nk ! Number of levels in the LBD and native grids, respectively - logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code - logical :: ierr - real :: tmpReal - integer :: nzf(4) - real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other - ! units depending on the coordinate + character(len=80) :: string ! Temporary strings + integer :: ke, nk ! Number of levels in the LBD and native grids, respectively + 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 @@ -105,7 +95,6 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, 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) @@ -141,14 +130,21 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, 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 layer by layer using only information from neighboring cells. +!! 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 + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] @@ -159,10 +155,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(lbd_CS), pointer :: CS !< Control structure for this module ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial - real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions - real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport @@ -176,11 +169,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G)) :: tracer_int, tracer_end !< integrated tracer in the native grid, before and after ! LBD is applied. - integer :: remap_method !< Reconstruction method integer :: i, j, k, m !< indices to loop over real :: Idt !< inverse of the time step [s-1] - real :: tmpReal, tmp1, tmp2 !< temporary variables + real :: tmp1, tmp2 !< temporary variables + 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, & @@ -252,7 +245,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) tmp2 = SUM(tracer_end) call sum_across_PEs(tmp1) call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total '//tracer%name//' before/after:', tmp1, tmp2 + if (is_root_pe()) write(*,*)'Total '//tracer%name//' before/after LBD:', tmp1, tmp2 endif ! Post the tracer diagnostics @@ -302,6 +295,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo + call cpu_clock_end(id_clock_lbd) + end subroutine lateral_boundary_diffusion !> Calculate the harmonic mean of two quantities @@ -579,7 +574,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer ! Local variables - real, dimension(:), allocatable :: dz_top + real, dimension(:), allocatable :: dz_top !< The LBD z grid to be created [L ~ m] real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U- or V-point in the ztop grid [H L2 conc ~> m3 conc] @@ -601,8 +596,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real :: hbl_min !< minimum BLD (left and right) [m] 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 - integer :: nk + real :: tmp1, tmp2 !< dummy variables + integer :: nk !< number of layers in the LBD grid F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then @@ -611,7 +606,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! Define vertical grid, dz_top call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - !allocate(dz_top(100)); dz_top(:) = 5.0 nk = SIZE(dz_top) ! allocate arrays @@ -633,7 +627,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ k_bot_diff = (k_bot_max - k_bot_min) ! tracer flux where the minimum BLD intersets layer - ! GMM, khtr_avg should be computed once khtr is 3D if ((CS%linear) .and. (k_bot_diff .gt. 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 @@ -1005,24 +998,28 @@ end function test_boundary_k_range !! 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. +!! 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 most +!! 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 can be applied using one of the three methods: +!! Boundary lateral diffusion is applied as follows: !! -!! * [Method #1: Along layer](@ref section_method) (default); -!! * [Method #2: Bulk layer](@ref section_method1); +!! 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 !! -!! A brief summary of these methods is provided below. +!! \subsection section_method Along layer approach !! -!! \subsection section_method1 Along layer approach (Method #1) +!! Here diffusion is applied layer by layer using only information from neighboring cells. !! -!! This is the recommended and more straight forward method where 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 #1: compute vertical indices containing boundary layer (boundary_k_range). +!! 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 @@ -1031,9 +1028,7 @@ end function test_boundary_k_range !! !! \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. This method does not require a limiter since KHTR -!! is already limted based on a diffusive CFL condition prior to the call of this -!! module. +!! in the left and right columns. !! !! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: !! @@ -1042,44 +1037,9 @@ end function test_boundary_k_range !! layer depth (k_bot_min) and the lower interface of the layer containing the !! maximum layer depth (k_bot_max). !! -!! \subsection section_method2 Bulk layer approach (Method #2) -!! -!! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model'.This -!! is a lower order representation (Kraus-Turner like approach) which assumes that -!! eddies are acting along well mixed layers (i.e., eddies do not know care about -!! vertical tracer gradients within the boundary layer). -!! -!! Step #1: 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: compute bulk averages (thickness weighted) tracer averages (phi_L and phi_R), -!! then calculate the bulk diffusive flux (F_{bulk}): -!! -!! \f[ F_{bulk} = -KHTR \times h_{eff} \times (\phi_R - \phi_L), \f] -!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the boundary layer depth -!! in the left and right columns (\f[ HBL_L \f] and \f[ HBL_R \f], respectively). -!! -!! Step #3: decompose F_bulk onto individual layers: -!! -!! \f[ F_{layer}(k) = F_{bulk} \times h_{frac}(k) , \f] -!! -!! where h_{frac} is -!! -!! \f[ h_{frac}(k) = h_u(k) \times \frac{1}{\sum(h_u)}. \f] -!! -!! h_u is the [harmonic mean](@ref section_harmonic_mean) of thicknesses at each layer. -!! Special care (layer reconstruction) must be taken at k_min = min(k_botL, k_bot_R). -!! -!! Step #4: 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 #5: limit the tracer flux so that 1) only down-gradient fluxes are applied, +!! 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: !! From fa2b4249b2a8496458693098300d845bed1fdf7c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Nov 2020 18:34:22 -0700 Subject: [PATCH 052/212] Undo chages in tracer_example and MOM_tracer_flow_control --- src/tracer/MOM_tracer_flow_control.F90 | 4 +-- src/tracer/tracer_example.F90 | 49 +++++++------------------- 2 files changed, 14 insertions(+), 39 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index aa0fe04dba..4c7c27c7e6 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -291,10 +291,8 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & - call USER_initialize_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS%USER_tracer_example_CSp, & + call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & sponge_CSp) - !call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & - ! 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) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index d52a4045b9..ef16cc985d 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -4,7 +4,7 @@ module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE +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 @@ -18,7 +18,6 @@ module USER_tracer_example use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux @@ -30,7 +29,7 @@ module USER_tracer_example public USER_register_tracer_example, USER_initialize_tracer, USER_tracer_stock public tracer_column_physics, USER_tracer_surface_state, USER_tracer_example_end -integer, parameter :: NTR = 2 !< The number of tracers in this module. +integer, parameter :: NTR = 1 !< The number of tracers in this module. !> The control structure for the USER_tracer_example module type, public :: USER_tracer_example_CS ; private @@ -42,7 +41,7 @@ module USER_tracer_example 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. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. - logical :: from_z !< if true, initialize tracers from a z file. + integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -102,10 +101,6 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) - call get_param(param_file, mdl, "TRACER_EXAMPLE_FROM_Z", CS%from_z, & - "If true, initialize tracers from a z file "//& - "using MOM_initialize_tracer_from_Z.", default=.false.) - allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 do m=1,NTR @@ -141,18 +136,15 @@ end function USER_register_tracer_example !> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine USER_initialize_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & +subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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(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)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - 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(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies @@ -188,29 +180,14 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, param_file, diag, if (.not.restart) then if (len_trim(CS%tracer_IC_file) >= 1) then - if (CS%from_z) then - ! Read the tracer concentrations from a netcdf file on a z grid. - do m=1,NTR - call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") - call MOM_error(NOTE,"USER_initialize_tracer: "//& - "initializing tracer "//trim(name)//& - " using MOM_initialize_tracer_from_Z ") - tr_ptr => CS%tr(:,:,:,m) - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = CS%tracer_IC_file, & - src_var_nam = name, & - useALEremapping = .true. ) - enddo - else - ! Read the tracer concentrations from a netcdf file on the native grid. - if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & - call MOM_error(FATAL, "USER_initialize_tracer: Unable to open "// & - CS%tracer_IC_file) - do m=1,NTR - call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") - call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) - enddo - endif +! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "USER_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo else do m=1,NTR do k=1,nz ; do j=js,je ; do i=is,ie From d5c87fc5aa33f8edb4faead36c17c761b5b11c79 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Nov 2020 14:36:17 -0700 Subject: [PATCH 053/212] change left_reals character var to be deferred length to prevent record overflow --- src/framework/MOM_string_functions.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 1293499930..5c04a77b7d 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -142,13 +142,13 @@ function left_reals(r,sep) real, intent(in) :: r(:) !< The array of real variables to convert to a string character(len=*), optional, intent(in) :: sep !< The separator between !! successive values, by default it is ', '. - character(len=1320) :: left_reals !< The output string + character(len=:), allocatable :: left_reals !< The output string - integer :: j, n, b, ns + integer :: j, n, ns logical :: doWrite character(len=10) :: separator - n=1 ; doWrite=.true. ; left_reals='' ; b=1 + n=1 ; doWrite=.true. ; left_reals='' if (present(sep)) then separator=sep ; ns=len(sep) else @@ -163,16 +163,15 @@ function left_reals(r,sep) endif endif if (doWrite) then - if (b>1) then ! Write separator if a number has already been written - write(left_reals(b:),'(A)') separator - b=b+ns + if (len(left_reals)>0) then ! Write separator if a number has already been written + left_reals = left_reals // separator(1:ns) endif if (n>1) then - write(left_reals(b:),'(A,"*",A)') trim(left_int(n)),trim(left_real(r(j))) + left_reals = left_reals // trim(left_int(n)) // "*" // trim(left_real(r(j))) else - write(left_reals(b:),'(A)') trim(left_real(r(j))) + left_reals = left_reals // trim(left_real(r(j))) endif - n=1 ; b=len_trim(left_reals)+1 + n=1 endif enddo end function left_reals From a798abcd12326f39b35fe60e72fe92cd769eb758 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 19 Nov 2020 16:38:31 -0500 Subject: [PATCH 054/212] consistent units + fix renormalization --- src/diagnostics/MOM_wave_structure.F90 | 52 ++++++++++++++++---------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 88b062472f..fd93294f06 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -11,6 +11,7 @@ module MOM_wave_structure ! 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 @@ -195,7 +196,13 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Pi = (4.0*atan(1.0)) S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 + + if (CS%debug) call chksum0(g_Rho0, "g/rho0 in wave struct", & + scale=US%Z_to_m*(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) @@ -267,7 +274,9 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !----------------------------------- if (G%mask2dT(i,j) > 0.5) then - lam = 1/(US%L_T_to_m_s**2 * cn(i,j)**2) + gprime(:) = 0.0 ! init gprime + pres(:) = 0.0 ! init pres + lam = 1/(cn(i,j)**2) ! Calculate drxh_sum if (use_EOS) then @@ -386,7 +395,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) - N2(K) = US%m_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + N2(K) = 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) @@ -407,7 +416,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Frist, populate interior rows do K=3,kc-1 row = K-1 ! indexing for TD matrix rows - gp_unscaled = US%m_to_Z*gprime(K) + gp_unscaled = gprime(K) lam_z(row) = lam*gp_unscaled a_diag(row) = gp_unscaled*(-Igu(K)) b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) @@ -419,14 +428,14 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo enddo ! Populate top row of tridiagonal matrix K=2 ; row = K-1 ; - gp_unscaled = US%m_to_Z*gprime(K) + gp_unscaled = gprime(K) lam_z(row) = lam*gp_unscaled a_diag(row) = 0.0 b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) c_diag(row) = gp_unscaled*(-Igl(K)) ! Populate bottom row of tridiagonal matrix K=kc ; row = K-1 - gp_unscaled = US%m_to_Z*gprime(K) + gp_unscaled = gprime(K) lam_z(row) = lam*gp_unscaled a_diag(row) = gp_unscaled*(-Igu(K)) b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) @@ -462,12 +471,11 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !(including surface and bottom) w2avg = 0.0 do k=1,nzm-1 - dz(k) = US%Z_to_m*Hc(k) + dz(k) = Hc(k) w2avg = w2avg + 0.5*(w_strct(K)**2+w_strct(K+1)**2)*dz(k) enddo - !### Some mathematical cancellations could occur in the next two lines. - w2avg = w2avg / htot(i,j) - w_strct(:) = w_strct(:) / sqrt(htot(i,j)*w2avg*I_a_int) + ! correct renormalization: + w_strct(:) = w_strct(:) * sqrt(htot(i,j)*a_int/w2avg) ! Calculate vertical structure function of u (i.e. dw/dz) do K=2,nzm-1 @@ -478,10 +486,9 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo u_strct(nzm) = (w_strct(nzm-1)- w_strct(nzm))/dz(nzm-1) ! Calculate wavenumber magnitude - f2 = G%CoriolisBu(I,J)**2 - !f2 = 0.25*US%s_to_T**2 *((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - ! (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - Kmag2 = US%m_to_L**2 * (freq**2 - f2) / (cn(i,j)**2 + cg_subRO**2) + f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1) + & + G%CoriolisBu(I,J-1) + G%CoriolisBu(I-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 @@ -489,16 +496,16 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 - int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) - int_w2 = int_w2 + 0.5*(w_strct2(K)+w_strct2(K+1)) * US%m_to_Z*dz(k) - int_N2w2 = int_N2w2 + 0.5*(w_strct2(K)*N2(K)+w_strct2(K+1)*N2(K+1)) * US%m_to_Z*dz(k) + 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 KE_term = 0.25*GV%Rho0*( ((freq**2 + f2) / (freq**2*Kmag2))*int_dwdz2 + int_w2 ) - PE_term = 0.25*GV%Rho0*( int_N2w2 / (US%s_to_T*freq)**2 ) + 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 @@ -510,7 +517,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo W_profile(:) = W0*w_strct(:) ! dWdz_profile(:) = W0*u_strct(:) ! Calculate average magnitude of actual horizontal velocity over a period - Uavg_profile(:) = US%Z_to_L*abs(W0*u_strct(:)) * sqrt((freq**2 + f2) / (2.0*freq**2*Kmag2)) + Uavg_profile(:) = abs(W0*u_strct(:)) * sqrt((freq**2 + f2) / (2.0*freq**2*Kmag2)) else W_profile(:) = 0.0 ! dWdz_profile(:) = 0.0 @@ -522,7 +529,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%z_depths(i,j,1:nzm) = z_int(1:nzm) CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else @@ -554,6 +561,11 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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%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 !> Solves a tri-diagonal system Ax=y using either the standard From 1f1688baad40bd967372950acf5809f7697894d9 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 19 Nov 2020 16:54:01 -0500 Subject: [PATCH 055/212] add debug --- src/diagnostics/MOM_wave_structure.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index fd93294f06..1b38ce151d 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -58,6 +58,7 @@ module MOM_wave_structure !! for internal tide for testing (BDM) real :: int_tide_source_y !< Y Location of generation site !! for internal tide for testing (BDM) + logical :: debug !! debugging prints end type wave_structure_CS @@ -721,6 +722,8 @@ subroutine wave_structure_init(Time, G, param_file, diag, CS) "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, "DEBUG", CS%debug, & + "debugging prints", default=.false.) CS%diag => diag From 220536b7a3c30ff49d5b15ffd8556032a08a10a3 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 19 Nov 2020 16:57:25 -0500 Subject: [PATCH 056/212] fix doxygen error --- src/diagnostics/MOM_wave_structure.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 1b38ce151d..0a8545334e 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -58,7 +58,7 @@ module MOM_wave_structure !! for internal tide for testing (BDM) real :: int_tide_source_y !< Y Location of generation site !! for internal tide for testing (BDM) - logical :: debug !! debugging prints + logical :: debug !< debugging prints end type wave_structure_CS From 36e18819076f6716884a1d17a962367d8d623eee Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 19 Nov 2020 17:52:50 -0500 Subject: [PATCH 057/212] remove whitespace --- src/diagnostics/MOM_wave_structure.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 0a8545334e..c290465315 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -566,7 +566,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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%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 !> Solves a tri-diagonal system Ax=y using either the standard From 95271cdfbc9d39cc8600802befa5af2952da28e8 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Nov 2020 18:35:51 -0700 Subject: [PATCH 058/212] change mesg character var to be deferred length to prevent record overflow --- src/framework/MOM_file_parser.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 2e7a14dbe4..522b0958c1 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1406,14 +1406,13 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & 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. - character(len=1320) :: mesg + character(len=:), allocatable :: mesg character(len=240) :: myunits !write(mesg, '(" ",a," ",a,": ",ES19.12,99(",",ES19.12))') & !write(mesg, '(" ",a," ",a,": ",G,99(",",G))') & ! trim(modulename), trim(varname), value - write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(left_reals(value)) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(value)) 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) From 7a5a0f7682ad3926d66cbd5d881da2783077dff7 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Nov 2020 19:50:13 -0700 Subject: [PATCH 059/212] real_array_string to deferred length --- src/framework/MOM_document.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 15d0839ee9..ff0934ac55 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -661,7 +661,7 @@ end function real_string !> Returns a character string of a comma-separated, compact formatted, reals !> e.g. "1., 2., 5*3., 5.E2", that give the list of values. function real_array_string(vals, sep) - character(len=1320) :: real_array_string !< The output string listing vals + character(len=:) ,allocatable :: real_array_string !< The output string listing vals real, intent(in) :: vals(:) !< The array of values to record character(len=*), & optional, intent(in) :: sep !< The separator between successive values, @@ -669,10 +669,10 @@ function real_array_string(vals, sep) ! Returns a character string of a comma-separated, compact formatted, reals ! e.g. "1., 2., 5*3., 5.E2" ! Local variables - integer :: j, n, b, ns + integer :: j, n, ns logical :: doWrite character(len=10) :: separator - n=1 ; doWrite=.true. ; real_array_string='' ; b=1 + n=1 ; doWrite=.true. ; real_array_string='' if (present(sep)) then separator=sep ; ns=len(sep) else @@ -687,16 +687,15 @@ function real_array_string(vals, sep) endif endif if (doWrite) then - if (b>1) then ! Write separator if a number has already been written - write(real_array_string(b:),'(A)') separator - b=b+ns + if(len(real_array_string)>0) then ! Write separator if a number has already been written + real_array_string = real_array_string // separator(1:ns) endif if (n>1) then - write(real_array_string(b:),'(A,"*",A)') trim(int_string(n)),trim(real_string(vals(j))) + real_array_string = real_array_string // trim(int_string(n)) // "*" // trim(real_string(vals(j))) else - write(real_array_string(b:),'(A)') trim(real_string(vals(j))) + real_array_string = real_array_string // trim(real_string(vals(j))) endif - n=1 ; b=len_trim(real_array_string)+1 + n=1 endif enddo end function real_array_string From 83785ae706e4ad3af67133a293130f1d869ba01e Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 23 Nov 2020 21:22:49 -0500 Subject: [PATCH 060/212] enable avg diags + more dim fixes --- src/diagnostics/MOM_wave_structure.F90 | 74 +++++++++++-------- .../lateral/MOM_internal_tides.F90 | 8 ++ .../vertical/MOM_internal_tide_input.F90 | 11 ++- 3 files changed, 61 insertions(+), 32 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index c290465315..b0c543f12f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -38,9 +38,9 @@ module MOM_wave_structure 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) [m s-1]. + !< Vertical structure of vertical velocity (normalized) [nondim]. real, allocatable, dimension(:,:,:) :: u_strct - !< Vertical structure of horizontal velocity (normalized) [m s-1]. + !< Vertical structure of horizontal velocity (normalized) [nondim]. 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- @@ -49,11 +49,11 @@ module MOM_wave_structure !< 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 [m]. + !< Depths of layer interfaces [Z ~> m]. real, allocatable, dimension(:,:,:) :: N2 - !< Squared buoyancy frequency at each interface [s-2]. + !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. integer, allocatable, dimension(:,:):: num_intfaces - !< Number of layer interfaces (including surface and bottom) + !< 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 @@ -111,13 +111,13 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [R L2 T-2 ~> Pa] + pres, & ! Interface pressure [R L H T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. + gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. + ! the thickness of the layer below (Igl) or above (Igu) it [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -130,10 +130,10 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] det, ddet real, dimension(SZI_(G),SZJ_(G)) :: & - htot ! The vertical sum of the thicknesses [Z ~> m] - real :: lam - real :: min_h_frac - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + 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] @@ -145,32 +145,38 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 in [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. + 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 - real :: I_a_int ! inverse of a_int + 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 + real :: Kmag2 ! magnitude of horizontal wave number squared [L-2 ~> m-2] logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. - real, dimension(SZK_(G)+1) :: w_strct, u_strct, W_profile, Uavg_profile, z_int, N2 - ! local representations of variables in CS; note, - ! not all rows will be filled if layers get merged! - real, dimension(SZK_(G)+1) :: w_strct2, u_strct2 - ! squared values - real, dimension(SZK_(G)) :: dz ! thicknesses of merged layers (same as Hc I hope) + + ! local representations of variables in CS; note, + ! not all rows will be filled if layers get merged! + real, dimension(SZK_(G)+1) :: w_strct ! Vertical structure of vertical velocity (normalized) [nondim]. + real, dimension(SZK_(G)+1) :: u_strct ! Vertical structure of horizontal velocity (normalized) [nondim]. + real, dimension(SZK_(G)+1) :: W_profile ! Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. + real, dimension(SZK_(G)+1) :: Uavg_profile ! Vertical profile of the magnitude of horizontal velocity [L T-1 ~> m s-1]. + real, dimension(SZK_(G)+1) :: z_int ! Integrated depth [Z ~> m] + real, dimension(SZK_(G)+1) :: N2 ! Squared buoyancy frequency at each interface [T-2 ~> s-2]. + real, dimension(SZK_(G)+1) :: w_strct2 ! squared values [nondim] + real, dimension(SZK_(G)+1) :: u_strct2 ! squared values [nondim] + real, dimension(SZK_(G)) :: dz ! thicknesses of merged layers (same as Hc I hope) [Z ~> m] ! real, dimension(SZK_(G)+1) :: dWdz_profile ! profile of dW/dz - real :: w2avg ! average of squared vertical velocity structure funtion + real :: w2avg ! average of squared vertical velocity structure funtion [Z ~> m] real :: int_dwdz2 real :: int_w2 real :: int_N2w2 real :: KE_term ! terms in vertically averaged energy equation real :: PE_term ! terms in vertically averaged energy equation real :: W0 ! A vertical velocity magnitude [Z T-1 ~> m s-1] - real :: gp_unscaled ! A version of gprime rescaled to [m s-2]. + real :: gp_unscaled ! A version of gprime rescaled to [L T-2 ~> m s-2]. real, dimension(SZK_(G)-1) :: lam_z ! product of eigen value and gprime(k); one value for each ! interface (excluding surface and bottom) real, dimension(SZK_(G)-1) :: a_diag, b_diag, c_diag @@ -199,8 +205,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 - if (CS%debug) call chksum0(g_Rho0, "g/rho0 in wave struct", & - scale=US%Z_to_m*(US%s_to_T**2)*US%kg_m3_to_R) + !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) @@ -396,7 +402,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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) = gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) N2(1) = N2(2) ; N2(kc+1) = N2(kc) @@ -415,6 +421,16 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! [-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. ! Frist, 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_diag(:) = 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 gp_unscaled = gprime(K) @@ -564,7 +580,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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%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 @@ -653,7 +669,7 @@ subroutine tridiag_solver(a, b, c, h, y, method, x) ! 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(WARNING, "tridiag_solver: matrix not symmetric; need symmetry when invoking TDMA_H") + call MOM_error(FATAL, "tridiag_solver: matrix not symmetric; need symmetry when invoking TDMA_H") endif enddo alpha = -c diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 2bb3c3b0f1..5d0cce3cd8 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -7,6 +7,7 @@ module MOM_internal_tides use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init +use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group use MOM_domains, only : AGRID, To_South, To_West, To_All @@ -202,6 +203,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & integer :: a, m, fr, i, j, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En + type(time_type) :: time_end + logical:: avg_enabled if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -497,6 +500,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & enddo ; enddo ! Output diagnostics.************************************************************ + avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) + call enable_averages(dt, time_end, CS%diag) + if (query_averaging_enabled(CS%diag)) then ! Output two-dimensional diagnostistics if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) @@ -587,6 +593,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & endif + call disable_averaging(CS%diag) + end subroutine propagate_int_tide !> Checks for energy conservation on computational domain diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index f5b9e7dbb7..059f5b9ab6 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -6,6 +6,7 @@ module MOM_int_tide_input use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled +use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : safe_alloc_ptr, post_data, register_diag_field use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE @@ -55,7 +56,7 @@ module MOM_int_tide_input !>@{ Diagnostic IDs - integer :: id_TKE_itidal = -1, id_Nb = -1, id_N2_bot = -1 + integer :: id_TKE_itidal_itide = -1, id_Nb = -1, id_N2_bot = -1 !>@} end type int_tide_input_CS @@ -140,10 +141,14 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) scale=US%RZ3_T3_to_W_m2) endif - if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, itide%TKE_itidal_input, CS%diag) + 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) 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) + call disable_averaging(CS%diag) + end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). @@ -409,7 +414,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) enddo ; enddo - CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & + 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) From 2c150d951f867c9793bdf7191fa76b149acb8492 Mon Sep 17 00:00:00 2001 From: Rahul Mahajan Date: Fri, 20 Nov 2020 13:47:38 -0500 Subject: [PATCH 061/212] bugfix: make the last argument in subroutine Update_Surface_Waves to be optional in src/user/MOM_wave_interface.F90. This is a bug from PR #23 bbdef39. --- src/user/MOM_wave_interface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index e9b0669f43..4ba1b779e3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -452,7 +452,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Day !< Current model time type(time_type), intent(in) :: dt !< Timestep as a time-type - type(mech_forcing), intent(in) :: forces !< MOM_forcing_type + type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables integer :: ii, jj, kk, b type(time_type) :: Day_Center From ad9862b407d4b81f6bc0943c65e2ca5d5255ee1b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 30 Nov 2020 18:59:06 -0700 Subject: [PATCH 062/212] Set maximum depth of the LBD grid z_max = min(BLD_max, H_min), where BLD_max is the deepest BLD and H_min is the shallowest water column depth. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 9db670c9a0..f33b949fd1 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -420,6 +420,7 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) 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_bld !< Deepest BLD integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) n = (2*nk)+3 @@ -439,12 +440,15 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) eta_all(kk+2) = hbl_L eta_all(kk+3) = hbl_R - ! find the minimum depth + ! 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, min_depth) + call unique(eta_all, n, eta_unique, max_depth) nk1 = SIZE(eta_unique) allocate(h(nk1-1)) From acdfdda71676307180bd88e2001143fa82ffc203 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 1 Dec 2020 10:29:17 -0700 Subject: [PATCH 063/212] Fix unit tests and declare max_depth --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 38 +++++++++++-------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index f33b949fd1..d4eab3f90f 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -420,6 +420,7 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) 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) @@ -807,74 +808,81 @@ logical function near_boundary_unit_tests( verbose ) 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+1, test_name, h1, (/1., 0.5, 1.5/) ) + 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+2, test_name, h1, (/0.5, 0.5, 0.5, 1.5/) ) + 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+2, test_name, h1, (/1., 0.5, 0.5, 2./) ) + 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+3, test_name, h1, (/0.5, 0.5, 0.5, 0.5, 2./) ) + 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, 1.0, CS%H_subroundoff, 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+1, test_name, h1, (/1., 1., 2./) ) + 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, test_name, h1, (/2., 2./) ) + 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+1, test_name, h1, (/1., 1., 2./) ) + 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, test_name, h1, (/2., 2./) ) + 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+1, test_name, h1, (/1., 1., 2./) ) + 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./), 2., 2., CS%H_subroundoff, h1) + 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/), 2., 2., CS%H_subroundoff, h1) + 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 @@ -906,7 +914,7 @@ logical function near_boundary_unit_tests( verbose ) 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,-3.0/) ) + 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 @@ -930,7 +938,7 @@ logical function near_boundary_unit_tests( verbose ) 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' + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed fluxes_layer_method' end function near_boundary_unit_tests From 4ab93b69dfa0858d6f0d46c211a2d4f9917eafe0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Dec 2020 11:25:06 -0500 Subject: [PATCH 064/212] +Deprecate the use of G%ke, using GV%ke instead Use GV%ke instead of G%ke everywhere in the MOM6 code to get the number of layers in a configuration. This required the addition of new vertical_grid_type arguments to a number of subroutines, and some unused variables were deleted. This is one of the final steps in a very long-term project to separate the vertical and horizontal grid types. All answers are bitwise identical, but there are new (non-optional) arguments to 51 subroutines. --- src/ALE/MOM_ALE.F90 | 4 +- src/core/MOM.F90 | 18 +- src/core/MOM_CoriolisAdv.F90 | 17 +- src/core/MOM_PressureForce_FV.F90 | 4 +- src/core/MOM_PressureForce_Montgomery.F90 | 12 +- src/core/MOM_barotropic.F90 | 16 +- src/core/MOM_boundary_update.F90 | 22 +- src/core/MOM_checksum_packages.F90 | 15 +- src/core/MOM_continuity_PPM.F90 | 70 +++--- src/core/MOM_dynamics_split_RK2.F90 | 28 +-- src/core/MOM_dynamics_unsplit.F90 | 18 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 14 +- src/core/MOM_forcing_type.F90 | 12 +- src/core/MOM_interface_heights.F90 | 4 +- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/core/MOM_open_boundary.F90 | 172 ++++++++------- src/core/MOM_variables.F90 | 18 +- src/diagnostics/MOM_PointAccel.F90 | 4 +- src/diagnostics/MOM_diagnostics.F90 | 17 +- src/diagnostics/MOM_sum_output.F90 | 44 ++-- src/diagnostics/MOM_wave_speed.F90 | 4 +- src/diagnostics/MOM_wave_structure.F90 | 7 +- src/framework/MOM_diag_mediator.F90 | 7 +- src/framework/MOM_diag_remap.F90 | 2 +- .../MOM_state_initialization.F90 | 204 +++++++++--------- .../MOM_tracer_initialization_from_Z.F90 | 26 +-- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- .../lateral/MOM_hor_visc.F90 | 21 +- .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 18 +- .../lateral/MOM_mixed_layer_restrat.F90 | 4 +- .../lateral/MOM_thickness_diffuse.F90 | 28 +-- .../vertical/MOM_ALE_sponge.F90 | 41 ++-- .../vertical/MOM_CVMix_KPP.F90 | 118 +++++----- .../vertical/MOM_CVMix_ddiff.F90 | 14 +- .../vertical/MOM_CVMix_shear.F90 | 36 ++-- .../vertical/MOM_bkgnd_mixing.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 22 +- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_diapyc_energy_req.F90 | 4 +- .../vertical/MOM_entrain_diffusive.F90 | 8 +- .../vertical/MOM_full_convection.F90 | 4 +- .../vertical/MOM_geothermal.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 4 +- .../vertical/MOM_opacity.F90 | 8 +- .../vertical/MOM_regularize_layers.F90 | 6 +- .../vertical/MOM_set_diffusivity.F90 | 20 +- .../vertical/MOM_set_viscosity.F90 | 4 +- src/parameterizations/vertical/MOM_sponge.F90 | 6 +- .../vertical/MOM_tidal_mixing.F90 | 69 +++--- .../vertical/MOM_vert_friction.F90 | 16 +- src/tracer/ISOMIP_tracer.F90 | 4 +- src/tracer/MOM_OCMIP2_CFC.F90 | 13 +- src/tracer/MOM_generic_tracer.F90 | 29 +-- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +- src/tracer/MOM_neutral_diffusion.F90 | 41 ++-- src/tracer/MOM_offline_main.F90 | 28 +-- src/tracer/MOM_tracer_Z_init.F90 | 12 +- src/tracer/MOM_tracer_diabatic.F90 | 2 +- src/tracer/MOM_tracer_flow_control.F90 | 5 +- src/tracer/MOM_tracer_hor_diff.F90 | 5 +- src/tracer/MOM_tracer_registry.F90 | 17 +- src/tracer/RGC_tracer.F90 | 4 +- src/tracer/ideal_age_example.F90 | 4 +- src/tracer/oil_tracer.F90 | 4 +- src/user/BFB_initialization.F90 | 2 +- src/user/DOME2d_initialization.F90 | 22 +- src/user/DOME_initialization.F90 | 6 +- src/user/ISOMIP_initialization.F90 | 8 +- src/user/Kelvin_initialization.F90 | 2 +- src/user/MOM_wave_interface.F90 | 36 ++-- src/user/Neverworld_initialization.F90 | 2 +- src/user/Phillips_initialization.F90 | 6 +- src/user/RGC_initialization.F90 | 11 +- src/user/Rossby_front_2d_initialization.F90 | 6 +- src/user/SCM_CVMix_tests.F90 | 2 +- src/user/adjustment_initialization.F90 | 4 +- src/user/baroclinic_zone_initialization.F90 | 2 +- src/user/benchmark_initialization.F90 | 4 +- src/user/circle_obcs_initialization.F90 | 4 +- src/user/dense_water_initialization.F90 | 2 +- src/user/dumbbell_initialization.F90 | 6 +- src/user/dyed_channel_initialization.F90 | 5 +- src/user/dyed_obcs_initialization.F90 | 2 +- src/user/external_gwave_initialization.F90 | 2 +- src/user/lock_exchange_initialization.F90 | 2 +- src/user/seamount_initialization.F90 | 4 +- src/user/shelfwave_initialization.F90 | 12 +- src/user/sloshing_initialization.F90 | 14 +- src/user/soliton_initialization.F90 | 7 +- src/user/supercritical_initialization.F90 | 15 +- src/user/tidal_bay_initialization.F90 | 17 +- src/user/user_change_diffusivity.F90 | 2 +- src/user/user_initialization.F90 | 9 +- 94 files changed, 815 insertions(+), 799 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index f130c2977a..c1042107ec 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -483,7 +483,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) dzRegrid(:,:,:) = 0.0 h_new(:,:,:) = 0.0 - if (debug) call MOM_tracer_chkinv("Before ALE_offline_inputs", G, h, Reg%Tr, Reg%ntr) + if (debug) call MOM_tracer_chkinv("Before ALE_offline_inputs", G, GV, h, Reg%Tr, Reg%ntr) ! 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 @@ -526,7 +526,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answers_2018=CS%answers_2018) call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answers_2018=CS%answers_2018) - if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, h_new, Reg%Tr, Reg%ntr) + if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, GV, h_new, Reg%Tr, Reg%ntr) ! Copy over the new layer thicknesses do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0e736e7312..4da7f66e85 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -505,7 +505,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS integer :: turns ! Number of quarter turns from input to model indexing G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -982,7 +982,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB G => CS%G ; GV => CS%GV ; US => CS%US ; IDs => CS%IDs - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1237,7 +1237,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & integer :: halo_sz ! The size of a halo where data must be valid. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") @@ -2400,7 +2400,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (associated(ALE_sponge_in_CSp)) then - call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, turns, param_file) + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, 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 @@ -2535,8 +2535,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call diag_update_remap_grids(diag) ! Setup the diagnostic grid storage types - call diag_grid_storage_init(CS%diag_pre_sync, G, diag) - call diag_grid_storage_init(CS%diag_pre_dyn, G, diag) + call diag_grid_storage_init(CS%diag_pre_sync, G, GV, diag) + call diag_grid_storage_init(CS%diag_pre_dyn, G, GV, diag) ! Calculate masks for diagnostics arrays in non-native coordinates ! This step has to be done after set_axes_info() because the axes needed @@ -2630,7 +2630,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) - call tracer_hor_diff_init(Time, G, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & + call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & CS%tracer_diff_CSp) call lock_tracer_registry(CS%tracer_Reg) @@ -2748,7 +2748,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%nstep_tot = 0 if (present(count_calls)) CS%count_calls = count_calls - call MOM_sum_output_init(G_in, US, param_file, dirs%output_directory, & + call MOM_sum_output_init(G_in, GV, US, param_file, dirs%output_directory, & CS%ntrunc, Time_init, CS%sum_output_CSp) ! Flag whether to save initial conditions in finish_MOM_initialization() or not. @@ -3343,7 +3343,7 @@ subroutine extract_surface_state(CS, sfc_state_in) endif if (associated(CS%tracer_flow_CSp)) then - call call_tracer_surface_state(sfc_state, h, G, CS%tracer_flow_CSp) + call call_tracer_surface_state(sfc_state, h, G, GV, CS%tracer_flow_CSp) endif if (CS%check_bad_sfc_vals) then diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index e6a7f7698f..10a6ecf3ac 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -233,7 +233,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_CoriolisAdv: Module must be initialized before it is used.") 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 = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke h_neglect = GV%H_subroundoff eps_vel = 1.0e-10*US%m_s_to_L_T h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. @@ -580,7 +580,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) endif ! Calculate KE and the gradient of KE - call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, US, CS) + call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) ! Calculate the tendencies of zonal velocity due to the Coriolis ! force and momentum advection. On a Cartesian grid, this is @@ -848,7 +848,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. !if (CS%id_hf_gKEu > 0) then - ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) ! enddo ; enddo ; enddo @@ -856,7 +856,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) !endif !if (CS%id_hf_gKEv > 0) then - ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) ! enddo ; enddo ; enddo @@ -884,7 +884,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) endif !if (CS%id_hf_rvxv > 0) then - ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) ! enddo ; enddo ; enddo @@ -892,7 +892,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) !endif !if (CS%id_hf_rvxu > 0) then - ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) ! enddo ; enddo ; enddo @@ -924,8 +924,9 @@ end subroutine CorAdCalc !> Calculates the acceleration due to the gradient of kinetic energy. -subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, US, CS) +subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocen grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure 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),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -944,7 +945,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, US, CS) real :: um2a, up2a, vm2a, vp2a ! Temporary variables [L4 T-2 ~> m4 s-2]. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4fd1b583d3..f6be2d360d 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -154,7 +154,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -490,7 +490,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index cade4e074d..b09805b347 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -128,7 +128,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -415,7 +415,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -638,7 +638,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) Rho0xG = Rho0 * GV%g_Earth @@ -740,7 +740,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) use_EOS = associated(tv%eqn_of_state) @@ -864,11 +864,11 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ CS%id_PFv_bc = register_diag_field('ocean_model', 'PFv_bc', diag%axesCvL, Time, & 'Density Gradient Meridional Pressure Force Accel.', "meter second-2", conversion=US%L_T2_to_m_s2) if (CS%id_PFu_bc > 0) then - call safe_alloc_ptr(CS%PFu_bc,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + call safe_alloc_ptr(CS%PFu_bc,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) CS%PFu_bc(:,:,:) = 0.0 endif if (CS%id_PFv_bc > 0) then - call safe_alloc_ptr(CS%PFv_bc,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + call safe_alloc_ptr(CS%PFv_bc,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) CS%PFv_bc(:,:,:) = 0.0 endif endif diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5e42a9575f..0cc1ab505c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -694,7 +694,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (.not.associated(CS)) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") if (.not.CS%split) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -2696,7 +2696,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) if (.not.associated(CS)) call MOM_error(FATAL, & "set_dtbt: Module MOM_barotropic must be initialized before it is used.") if (.not.CS%split) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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, & @@ -3006,7 +3006,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(OBC_segment_type), pointer :: segment !< Open boundary segment is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + 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 isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw @@ -3249,7 +3249,7 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) apply_OBCs = (OBC%number_of_segments > 0) endif ; endif ; endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff @@ -4168,7 +4168,7 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) "Module MOM_barotropic must be initialized before it is used.") if (.not.CS%split) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta) do j=js,je @@ -4271,7 +4271,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, integer :: wd_halos(2), bt_halo_sz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed @@ -4580,7 +4580,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call do_group_pass(pass_a_polarity, CS%BT_domain) if (use_BT_cont_type) & - call alloc_BT_cont_type(BT_cont, G, (CS%hvel_scheme == FROM_BT_CONT)) + call alloc_BT_cont_type(BT_cont, G, GV, (CS%hvel_scheme == FROM_BT_CONT)) if (CS%debug) then ! Make a local copy of loop ranges for chksum calls allocate(CS%debug_BT_HI) @@ -4698,7 +4698,7 @@ 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,G%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo + do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index d7ab6a1922..658a2d7ccf 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -14,9 +14,9 @@ module MOM_boundary_update use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS use MOM_open_boundary, only : register_file_OBC, file_OBC_end use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type use tidal_bay_initialization, only : tidal_bay_set_OBC_data, register_tidal_bay_OBC use tidal_bay_initialization, only : tidal_bay_OBC_end, tidal_bay_OBC_CS use Kelvin_initialization, only : Kelvin_set_OBC_data, register_Kelvin_OBC @@ -120,31 +120,17 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) type(update_OBC_CS), pointer :: CS !< Control structure for OBCs type(time_type), intent(in) :: Time !< Model time - ! Local variables - logical :: read_OBC_eta = .false. - logical :: read_OBC_uv = .false. - logical :: read_OBC_TS = .false. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isd_off, jsd_off - integer :: IsdB, IedB, JsdB, JedB - character(len=40) :: mdl = "update_OBC_data" ! This subroutine's name. - character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! Something here... with CS%file_OBC_CSp? ! if (CS%use_files) & ! call update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (CS%use_tidal_bay) & - call tidal_bay_set_OBC_data(OBC, CS%tidal_bay_OBC_CSp, G, h, Time) + call tidal_bay_set_OBC_data(OBC, CS%tidal_bay_OBC_CSp, G, GV, h, Time) if (CS%use_Kelvin) & call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, GV, US, h, Time) if (CS%use_shelfwave) & - call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, h, Time) + call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, h, Time) if (CS%use_dyed_channel) & - call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, Time) + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, Time) if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 70ba32644f..ae53a4086d 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -64,8 +64,7 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy real :: scale_vel ! The scaling factor to convert velocities to [m s-1] logical :: sym - integer :: is, ie, js, je, nz, hs - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + integer :: hs ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie @@ -99,10 +98,9 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully !! symmetric computational domain. real :: L_T_to_m_s ! A rescaling factor for velocities [m T s-1 L-1 ~> nondim] or [nondim] - integer :: is, ie, js, je, nz, hs + integer :: hs logical :: sym - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke L_T_to_m_s = 1.0 ; if (present(US)) L_T_to_m_s = US%L_T_to_m_s ! Note that for the chksum calls to be useful for reproducing across PE @@ -125,9 +123,8 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). - integer :: is, ie, js, je, nz, hs - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - hs=1; if (present(haloshift)) hs=haloshift + integer :: hs + hs=1 ; if (present(haloshift)) hs=haloshift if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs) if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs) @@ -214,10 +211,8 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric !! computational domain. - integer :: is, ie, js, je, nz logical :: sym - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke sym=.false.; if (present(symmetric)) sym=symmetric ! Note that for the chksum calls to be useful for reproducing across PE @@ -277,7 +272,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe character(len=80) :: lMsg integer :: is, ie, js, je, nz, i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke do_TS = associated(Temp) .and. associated(Salt) tmp_A(:,:) = 0.0 diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 995827959d..1f9a2c3bbd 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -76,6 +76,7 @@ module MOM_continuity_PPM subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, OBC, & visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(continuity_PPM_CS), pointer :: CS !< Module's control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -90,7 +91,6 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, O real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: vh !< Meridional volume flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: uhbt !< The summed volume flux through zonal faces @@ -131,7 +131,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, O integer :: i, j, k logical :: x_first - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_min = GV%Angstrom_H @@ -277,7 +277,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & local_Flather_OBC = OBC%Flather_u_BCs_exist_globally local_open_BC = OBC%open_u_BCs_exist_globally endif ; endif - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt I_dt = 1.0 / dt @@ -429,7 +429,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(uhbt)) then call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & - du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, .true., uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz @@ -448,7 +448,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (set_BT_cont) then call set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0,& - du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh @@ -507,10 +507,10 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then - call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, US, LB, & + call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_u, OBC) else - call zonal_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt, G, US, LB, & + call zonal_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_u, OBC) endif endif ; endif @@ -600,9 +600,10 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & end subroutine zonal_flux_layer !> Sets the effective interface thickness at each zonal velocity point. -subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, US, LB, vol_CFL, & +subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, & marginal, visc_rem_u, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. @@ -634,7 +635,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, US, LB, vol_CFL, & real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. logical :: local_open_BC integer :: i, j, k, ish, ieh, jsh, jeh, nz, n - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh @@ -708,9 +709,10 @@ end subroutine zonal_face_thickness !> Returns the barotropic velocity adjustment that gives the !! desired barotropic (layer-summed) transport. subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & - du, du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & + du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. @@ -768,7 +770,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & integer :: i, k, nz, itt, max_itts = 20 logical :: full_prec, domore, do_I(SZIB_(G)) - nz = G%ke + nz = GV%ke full_prec = .true. ; if (present(full_precision)) full_prec = full_precision uh_aux(:,:) = 0.0 ; duhdu(:,:) = 0.0 @@ -872,9 +874,10 @@ end subroutine zonal_flux_adjust !> Sets a structure that describes the zonal barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, & - du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. @@ -940,13 +943,13 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, logical :: domore integer :: i, k, nz - nz = G%ke ; Idt = 1.0 / dt + nz = GV%ke ; Idt = 1.0 / dt min_visc_rem = 0.1 ; CFL_min = 1e-6 ! Diagnose the zero-transport correction, du0. do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & - du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, .true.) ! Determine the westerly- and easterly- fluxes. Choose a sufficiently @@ -1101,7 +1104,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & local_Flather_OBC = OBC%Flather_v_BCs_exist_globally local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif ; endif - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt I_dt = 1.0 / dt @@ -1249,7 +1252,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(vhbt)) then call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & - dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, .true., vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz @@ -1267,7 +1270,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (set_BT_cont) then call set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0,& - dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh @@ -1326,10 +1329,10 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & 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, US, LB, & + 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, visc_rem_v, OBC) else - call merid_face_thickness(v, h_in, h_L, h_R, BT_cont%h_v, dt, G, US, LB, & + 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, visc_rem_v, OBC) endif endif ; endif @@ -1423,9 +1426,10 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & end subroutine merid_flux_layer !> Sets the effective interface thickness at each meridional velocity point. -subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, US, LB, vol_CFL, & +subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, & marginal, visc_rem_v, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. 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),SZK_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. @@ -1457,7 +1461,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, US, LB, vol_CFL, & real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. logical :: local_open_BC integer :: i, j, k, ish, ieh, jsh, jeh, n, nz - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh @@ -1532,17 +1536,18 @@ end subroutine merid_face_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & - dv, dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & + dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& - intent(in) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the momentum originally !! in a layer that remains after a time-step of viscosity, and the @@ -1591,7 +1596,7 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 integer :: i, k, nz, itt, max_itts = 20 logical :: full_prec, domore, do_I(SZI_(G)) - nz = G%ke + nz = GV%ke full_prec = .true. ; if (present(full_precision)) full_prec = full_precision vh_aux(:,:) = 0.0 ; dvhdv(:,:) = 0.0 @@ -1695,9 +1700,10 @@ end subroutine meridional_flux_adjust !> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, & - dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. 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),SZK_(G)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. @@ -1763,13 +1769,13 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, logical :: domore integer :: i, k, nz - nz = G%ke ; Idt = 1.0 / dt + nz = GV%ke ; Idt = 1.0 / dt min_visc_rem = 0.1 ; CFL_min = 1e-6 ! Diagnose the zero-transport correction, dv0. do i=ish,ieh ; zeros(i) = 0.0 ; enddo call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & - dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, .true.) ! Determine the southerly- and northerly- fluxes. Choose a sufficiently @@ -2273,7 +2279,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "tolerance for SSH is 4 times this value. The default "//& "is 0.5*NK*ANGSTROM, and this should not be set less "//& "than about 10^-15*MAXIMUM_DEPTH.", units="m", scale=GV%m_to_H, & - default=0.5*G%ke*GV%Angstrom_m, unscaled=tol_eta_m) + default=0.5*GV%ke*GV%Angstrom_m, unscaled=tol_eta_m) !### ETA_TOLERANCE_AUX can be obsoleted. call get_param(param_file, mdl, "ETA_TOLERANCE_AUX", CS%tol_eta_aux, & diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 64a9c18b97..50b893dae7 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -348,7 +348,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_stencil - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 @@ -445,7 +445,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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, CS%PFu, CS%PFv) + 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) @@ -469,7 +469,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s enddo ; enddo enddo if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, u_bc_accel, v_bc_accel) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) endif call cpu_clock_end(id_clock_btforce) @@ -631,7 +631,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, US, dt_pred) + 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) @@ -727,7 +727,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s enddo ; enddo enddo if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, u_bc_accel, v_bc_accel) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) endif call cpu_clock_end(id_clock_btforce) @@ -840,7 +840,7 @@ 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, US, dt) + call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, 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. @@ -885,14 +885,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. !if (CS%id_hf_PFu > 0) then - ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq ! hf_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_PFu, hf_PFu, CS%diag) !endif !if (CS%id_hf_PFv > 0) then - ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ! hf_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) ! enddo ; enddo ; enddo @@ -918,14 +918,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif !if (CS%id_hf_CAu > 0) then - ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq ! hf_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_CAu, hf_CAu, CS%diag) !endif !if (CS%id_hf_CAv > 0) then - ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ! hf_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) ! enddo ; enddo ; enddo @@ -951,14 +951,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif !if (CS%id_hf_u_BT_accel > 0) then - ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq ! hf_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_u_BT_accel, hf_u_BT_accel, CS%diag) !endif !if (CS%id_hf_v_BT_accel > 0) then - ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ! hf_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) ! enddo ; enddo ; enddo @@ -1137,7 +1137,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 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 = G%ke + 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 @@ -1233,7 +1233,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 6b9aa8e759..a129e71465 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -235,7 +235,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 dt_pred = dt / 3.0 @@ -320,8 +320,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) - call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) endif ! up = u + dt_pred * (PFu + CAu) @@ -386,8 +386,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) - call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) endif ! upp = u + dt/2 * ( PFu + CAu ) @@ -463,8 +463,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u = u + dt * ( PFu + CAu ) if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) - call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) endif do k=1,nz ; do j=js,je ; do I=Isq,Ieq u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) @@ -617,7 +617,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS real :: H_convert 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 = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not.associated(CS)) call MOM_error(FATAL, & @@ -661,7 +661,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc_CSp, MEKE) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 4181ab519d..307874eb14 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -245,7 +245,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 dt_pred = dt * CS%BE @@ -315,9 +315,9 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call update_OBC_data(CS%OBC, G, GV, US, tv, h_in, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) - call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) - call open_boundary_zero_normal_flow(CS%OBC, G, CS%diffu, CS%diffv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%diffu, CS%diffv) endif ! up+[n-1/2] = u[n-1] + dt_pred * (PFu + CAu) @@ -371,7 +371,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, G, GV, US, CS%CoriolisAdv_CSp) call cpu_clock_end(id_clock_Cor) if (associated(CS%OBC)) then - call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) endif ! call enable_averages(dt, Time_local, CS%diag) ?????????????????????/ @@ -563,7 +563,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag real :: H_convert 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 = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not.associated(CS)) call MOM_error(FATAL, & @@ -623,7 +623,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc_CSp, MEKE) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ed4b8d1ba2..dd7559aeac 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -460,7 +460,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & I_Cp = 1.0 / fluxes%C_p I_Cp_Hconvert = 1.0 / (GV%H_to_RZ * fluxes%C_p) - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke calculate_diags = .true. if (present(skip_diags)) calculate_diags = .not. skip_diags @@ -972,7 +972,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt 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, G%ke+1 + 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 @@ -1025,8 +1025,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo - integer :: is, ie, js, je, nz, hshift - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + integer :: hshift hshift = 1 ; if (present(haloshift)) hshift = haloshift @@ -1119,10 +1118,9 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo - integer :: is, ie, js, je, nz, hshift - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + integer :: hshift - hshift=1; if (present(haloshift)) hshift=haloshift + hshift = 1 ; if (present(haloshift)) hshift = haloshift ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index b8cf161148..d016b962d4 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -60,7 +60,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) isv = G%isc-halo ; iev = G%iec+halo ; jsv = G%jsc-halo ; jev = G%jec+halo - nz = G%ke + nz = GV%ke if ((isvG%ied) .or. (jsvG%jed)) & call MOM_error(FATAL,"find_eta called with an overly large halo_size.") @@ -174,7 +174,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) 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 = G%ke + 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 diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index c134366cd0..68a4373314 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -113,7 +113,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec endif - nz = G%ke ; IsdB = G%IsdB + 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 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 46d144a8c6..3c6ada5fd1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2076,8 +2076,9 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) end subroutine open_boundary_impose_land_mask !> Make sure the OBC tracer reservoirs are initialized. -subroutine setup_OBC_tracer_reservoirs(G, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine setup_OBC_tracer_reservoirs(G, GV, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables type(OBC_segment_type), pointer :: segment => NULL() @@ -2090,7 +2091,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) I = segment%HI%IsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,GV%ke do j=segment%HI%jsd,segment%HI%jed OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%t(i,j,k) enddo @@ -2101,7 +2102,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) J = segment%HI%JsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,GV%ke do i=segment%HI%isd,segment%HI%ied OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%t(i,J,k) enddo @@ -2114,10 +2115,11 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) end subroutine setup_OBC_tracer_reservoirs -!> Apply radiation conditions to 3D u,v at open boundaries -subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure +!> Apply radiation conditions to 3D u,v at open boundaries +subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u_new !< On exit, new u values on open boundaries !! On entry, the old time-level v but including !! barotropic accelerations [L T-1 ~> m s-1]. @@ -2149,7 +2151,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(OBC)) return @@ -2166,14 +2168,14 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) segment=>OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W .and. segment%radiation) then - do k=1,G%ke + do k=1,GV%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%rx_norm_rad(I,j,k) = OBC%rx_normal(I,j,k) enddo enddo elseif (segment%is_N_or_S .and. segment%radiation) then - do k=1,G%ke + do k=1,GV%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) @@ -2181,7 +2183,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo endif if (segment%is_E_or_W .and. segment%oblique) then - do k=1,G%ke + do k=1,GV%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%rx_norm_obl(I,j,k) = OBC%rx_oblique(I,j,k) @@ -2190,7 +2192,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo enddo elseif (segment%is_N_or_S .and. segment%oblique) then - do k=1,G%ke + do k=1,GV%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%rx_norm_obl(i,J,k) = OBC%rx_oblique(i,J,k) @@ -2210,7 +2212,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I = segment%HI%IsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,GV%ke do j=segment%HI%jsd,segment%HI%jed segment%tr_Reg%Tr(m)%tres(I,j,k) = OBC%tres_x(I,j,k,m) enddo @@ -2221,7 +2223,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) J = segment%HI%JsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,GV%ke do i=segment%HI%isd,segment%HI%ied segment%tr_Reg%Tr(m)%tres(i,J,k) = OBC%tres_y(i,J,k,m) enddo @@ -2237,7 +2239,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do n=1,OBC%number_of_segments segment=>OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%oblique) call gradient_at_q_points(G, segment, u_new(:,:,:), v_new(:,:,:)) + if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB if (I Applies OBC values stored in segments to 3d u,v fields -subroutine open_boundary_apply_normal_flow(OBC, G, u, v) +subroutine open_boundary_apply_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_(G)), intent(inout) :: u !< u field to update on open !! boundaries [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open @@ -3246,12 +3249,12 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) elseif (segment%radiation .or. segment%oblique .or. segment%gradient) then if (segment%is_E_or_W) then I=segment%HI%IsdB - do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = segment%normal_vel(I,j,k) enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB - do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = segment%normal_vel(i,J,k) enddo ; enddo endif @@ -3261,10 +3264,11 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) 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, u, v) +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_(G)), intent(inout) :: u !< u field to update on open boundaries real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open boundaries ! Local variables @@ -3279,12 +3283,12 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) cycle elseif (segment%is_E_or_W) then I=segment%HI%IsdB - do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = 0. enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB - do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = 0. enddo ; enddo endif @@ -3293,9 +3297,10 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) end subroutine open_boundary_zero_normal_flow !> Calculate the tangential gradient of the normal flow at the boundary q-points. -subroutine gradient_at_q_points(G, segment, uvel, vvel) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(OBC_segment_type), pointer :: segment !< OBC segment structure +subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(OBC_segment_type), pointer :: segment !< OBC segment structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uvel !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vvel !< meridional velocity [L T-1 ~> m s-1] integer :: i,j,k @@ -3305,14 +3310,14 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) if (segment%is_E_or_W) then if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%isdB - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) segment%grad_normal(J,1,k) = (uvel(I-1,j+1,k)-uvel(I-1,j,k)) * G%mask2dBu(I-1,J) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo if (segment%oblique_tan) then - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) segment%grad_tan(j,1,k) = (vvel(i-1,J,k)-vvel(i-1,J-1,k)) * G%mask2dT(i-1,j) segment%grad_tan(j,2,k) = (vvel(i,J,k)-vvel(i,J-1,k)) * G%mask2dT(i,j) @@ -3320,7 +3325,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo endif if (segment%oblique_grad) then - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j) @@ -3331,14 +3336,14 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) endif else ! western segment I=segment%HI%isdB - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) segment%grad_normal(J,1,k) = (uvel(I+1,j+1,k)-uvel(I+1,j,k)) * G%mask2dBu(I+1,J) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo if (segment%oblique_tan) then - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) segment%grad_tan(j,1,k) = (vvel(i+2,J,k)-vvel(i+2,J-1,k)) * G%mask2dT(i+2,j) segment%grad_tan(j,2,k) = (vvel(i+1,J,k)-vvel(i+1,J-1,k)) * G%mask2dT(i+1,j) @@ -3346,7 +3351,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo endif if (segment%oblique_grad) then - do k=1,G%ke + do k=1,GV%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i+3,J,k) - vvel(i+2,J,k))*G%IdxBu(I+2,J)) - & (vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1)) * G%mask2dCu(I+2,j) @@ -3359,14 +3364,14 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) elseif (segment%is_N_or_S) then if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%jsdB - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) segment%grad_normal(I,1,k) = (vvel(i+1,J-1,k)-vvel(i,J-1,k)) * G%mask2dBu(I,J-1) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo if (segment%oblique_tan) then - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) segment%grad_tan(i,1,k) = (uvel(I,j-1,k)-uvel(I-1,j-1,k)) * G%mask2dT(i,j-1) segment%grad_tan(i,2,k) = (uvel(I,j,k)-uvel(I-1,j,k)) * G%mask2dT(i,j) @@ -3374,7 +3379,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo endif if (segment%oblique_grad) then - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - & (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2) @@ -3385,14 +3390,14 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) endif else ! south segment J=segment%HI%jsdB - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) segment%grad_normal(I,1,k) = (vvel(i+1,J+1,k)-vvel(i,J+1,k)) * G%mask2dBu(I,J+1) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo if (segment%oblique_tan) then - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) segment%grad_tan(i,1,k) = (uvel(I,j+2,k)-uvel(I-1,j+2,k)) * G%mask2dT(i,j+2) segment%grad_tan(i,2,k) = (uvel(I,j+1,k)-uvel(I-1,j+1,k)) * G%mask2dT(i,j+1) @@ -3400,7 +3405,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo endif if (segment%oblique_grad) then - do k=1,G%ke + do k=1,GV%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - & (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) @@ -3417,8 +3422,9 @@ end subroutine gradient_at_q_points !> Sets the initial values of the tracer open boundary conditions. !! Redoing this elsewhere. -subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) +subroutine set_tracer_data(OBC, tv, h, G, GV, PF, tracer_Reg) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness @@ -3435,7 +3441,7 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) real :: temp_u(G%domain%niglobal+1,G%domain%njglobal) real :: temp_v(G%domain%niglobal,G%domain%njglobal+1) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 @@ -3454,22 +3460,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB - do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) enddo ; enddo elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB - do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) enddo ; enddo elseif (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB - do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) enddo ; enddo elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB - do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) enddo ; enddo endif @@ -3641,18 +3647,19 @@ end subroutine deallocate_OBC_segment_data !> Set tangential velocities outside of open boundaries to silly values !! (used for checking the interior state is independent of values outside !! of the domain). -subroutine open_boundary_test_extern_uv(G, OBC, u, v) +subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(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] ! Local variables integer :: i, j, k, n if (.not. associated(OBC)) return do n = 1, OBC%number_of_segments - do k = 1, G%ke + do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB if (OBC%segment(n)%direction == OBC_DIRECTION_N) then @@ -3763,7 +3770,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - nz=G%ke + nz=GV%ke turns = G%HI%turns @@ -3803,7 +3810,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) segment%Htot(I,j)=0.0 - do k=1,G%ke + 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) enddo @@ -3816,14 +3823,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) segment%Htot(i,J)=0.0 - do k=1,G%ke + 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) enddo enddo endif - allocate(h_stack(G%ke)) + allocate(h_stack(GV%ke)) h_stack(:) = 0.0 do m = 1,segment%num_fields if (segment%field(m)%fid > 0) then @@ -3835,25 +3842,25 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%field(m)%nk_src > 1) then if (segment%is_E_or_W) then if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase' .or. & segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) ! 3rd dim is constituent else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) endif else if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase' .or. & segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) endif endif else @@ -4038,19 +4045,19 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j)>0.) then h_stack(:) = h(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)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j+1)>0.) then h_stack(:) = h(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)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4065,7 +4072,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & - G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) + GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif enddo endif @@ -4084,19 +4091,19 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i,J)>0.) then h_stack(:) = h(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)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i+1,J)>0.) then h_stack(:) = h(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)%buffer_src(I,J,:), & - G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4111,7 +4118,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & - G%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) + GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) endif enddo endif @@ -4130,37 +4137,37 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. associated(segment%field(m)%buffer_dst)) then if (segment%is_E_or_W) then if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) else if (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) elseif (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) elseif (segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & .or. segment%field(m)%name == 'SSHphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) endif else if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) elseif (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) elseif (segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & .or. segment%field(m)%name == 'SSHphase') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) endif endif segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value @@ -4185,7 +4192,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - do k=1,G%ke + do k=1,GV%ke segment%normal_vel(I,j,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,j,k) + tidal_vel) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k)*segment%h(I,j,k) * G%dyCu(I,j) normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) @@ -4206,7 +4213,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - do k=1,G%ke + do k=1,GV%ke segment%normal_vel(i,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(i,J,k) + tidal_vel) segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k)*segment%h(i,J,k) * & G%dxCv(i,J) @@ -4228,7 +4235,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - do k=1,G%ke + do k=1,GV%ke segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo if (associated(segment%nudged_tangential_vel)) & @@ -4246,7 +4253,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - do k=1,G%ke + do k=1,GV%ke segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo if (associated(segment%nudged_tangential_vel)) & @@ -4257,7 +4264,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) associated(segment%tangential_grad)) then I=is_obc do J=js_obc,je_obc - do k=1,G%ke + do k=1,GV%ke segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) if (associated(segment%nudged_tangential_grad)) & segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) @@ -4267,7 +4274,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) associated(segment%tangential_grad)) then J=js_obc do I=is_obc,ie_obc - do k=1,G%ke + do k=1,GV%ke segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) if (associated(segment%nudged_tangential_grad)) & segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) @@ -4633,8 +4640,9 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments -subroutine fill_temp_salt_segments(G, OBC, tv) +subroutine fill_temp_salt_segments(G, GV, OBC, tv) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure @@ -4650,7 +4658,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) call pass_var(tv%T, G%Domain) call pass_var(tv%S, G%Domain) - nz = G%ke + nz = GV%ke do n=1, OBC%number_of_segments segment => OBC%segment(n) @@ -4689,7 +4697,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, OBC) + call setup_OBC_tracer_reservoirs(G, GV, OBC) end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and @@ -5476,7 +5484,7 @@ subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CSp, OBC) enddo if (use_temperature) & - call fill_temp_salt_segments(G, OBC, tv) + call fill_temp_salt_segments(G, GV, OBC, tv) call open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) end subroutine rotate_OBC_init diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index ebd269c960..531944f361 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -8,6 +8,7 @@ module MOM_variables use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type @@ -473,14 +474,15 @@ subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) end subroutine rotate_surface_state !> Allocates the arrays contained within a BT_cont_type and initializes them to 0. -subroutine alloc_BT_cont_type(BT_cont, G, alloc_faces) - type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - logical, optional, intent(in) :: alloc_faces !< If present and true, allocate +subroutine alloc_BT_cont_type(BT_cont, G, GV, alloc_faces) + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, optional, intent(in) :: alloc_faces !< If present and true, allocate !! memory for effective face thicknesses. - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (associated(BT_cont)) call MOM_error(FATAL, & @@ -502,8 +504,8 @@ subroutine alloc_BT_cont_type(BT_cont, G, alloc_faces) allocate(BT_cont%vBT_NN(isd:ied,JsdB:JedB)) ; BT_cont%vBT_NN(:,:) = 0.0 if (present(alloc_faces)) then ; if (alloc_faces) then - allocate(BT_cont%h_u(IsdB:IedB,jsd:jed,1:G%ke)) ; BT_cont%h_u(:,:,:) = 0.0 - allocate(BT_cont%h_v(isd:ied,JsdB:JedB,1:G%ke)) ; BT_cont%h_v(:,:,:) = 0.0 + allocate(BT_cont%h_u(IsdB:IedB,jsd:jed,1:nz)) ; BT_cont%h_u(:,:,:) = 0.0 + allocate(BT_cont%h_v(isd:ied,JsdB:JedB,1:nz)) ; BT_cont%h_v(:,:,:) = 0.0 endif ; endif end subroutine alloc_BT_cont_type diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index f6326b06fa..aeee768272 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -110,7 +110,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return - nz = G%ke + nz = GV%ke if (CS%cols_written < CS%max_writes) then CS%cols_written = CS%cols_written + 1 @@ -443,7 +443,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return - nz = G%ke + nz = GV%ke if (CS%cols_written < CS%max_writes) then CS%cols_written = CS%cols_written + 1 diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 1f55801064..f1c3a0c777 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -257,7 +257,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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 = G%ke ; nkmb = GV%nk_rho_varies + nz = GV%ke ; nkmb = GV%nk_rho_varies ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 @@ -860,7 +860,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%id_mass_wt > 0) then do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo @@ -975,7 +975,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS real :: KE_h(SZI_(G),SZJ_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 do j=js-1,je ; do i=is-1,ie @@ -1431,7 +1431,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy real :: H_to_RZ_dt ! A conversion factor from accumulated transports to fluxes ! [R Z H-1 T-1 ~> kg m-3 s-1 or s-1]. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 1. / dt_trans H_to_RZ_dt = GV%H_to_RZ * Idt @@ -1526,7 +1526,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (associated(CS)) then @@ -1866,7 +1866,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag long_name='Sea Water Pressure at Sea Floor', standard_name='sea_water_pressure_at_sea_floor', & units='Pa', conversion=US%RL2_T2_to_Pa) - call set_dependent_diagnostics(MIS, ADp, CDp, G, CS) + call set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) end subroutine MOM_diagnostics_init @@ -2174,7 +2174,7 @@ end subroutine write_static_fields !> This subroutine sets up diagnostics upon which other diagnostics depend. -subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) +subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to !! the fields and accelerations making up ocean !! internal physical state. @@ -2183,12 +2183,13 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) type(cont_diag_ptrs), intent(inout) :: CDp !< Structure pointing to terms in continuity !! equation. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diagnostics_CS), pointer :: CS !< Pointer to the control structure for this !! module. ! This subroutine sets up diagnostics upon which other diagnostics depend. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (associated(CS%dKE_dt) .or. associated(CS%PE_to_KE) .or. & diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 1742ec1247..ab0e0e1af1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -131,19 +131,20 @@ module MOM_sum_output contains !> MOM_sum_output_init initializes the parameters and settings for the MOM_sum_output module. -subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & +subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & Input_start_time, 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. - character(len=*), intent(in) :: directory !< The directory where the energy file goes. - integer, target, intent(inout) :: ntrnc !< The integer that stores the number of times - !! the velocity has been truncated since the - !! last call to write_energy. - type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. - type(Sum_output_CS), pointer :: CS !< A pointer that is set to point to 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. + 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 where the energy file goes. + integer, target, intent(inout) :: ntrnc !< The integer that stores the number of times + !! the velocity has been truncated since the + !! last call to write_energy. + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + 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. real :: Rho_0 ! A reference density [kg m-3] @@ -248,8 +249,8 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & default=.false.) endif - allocate(CS%lH(G%ke)) - call depth_list_setup(G, US, CS) + allocate(CS%lH(GV%ke)) + call depth_list_setup(G, GV, US, CS) else CS%list_size = 0 endif @@ -481,7 +482,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ local_open_BC = (OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) endif ; endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) @@ -1089,11 +1090,12 @@ end subroutine accumulate_net_input !! cross sectional areas at each depth and the volume of fluid deeper !! than each depth. This might be read from a previously created file !! or it might be created anew. (For now only new creation occurs. -subroutine depth_list_setup(G, US, 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(Sum_output_CS), pointer :: CS !< The control structure returned by a - !! previous call to MOM_sum_output_init. +subroutine depth_list_setup(G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. ! Local variables integer :: k @@ -1111,7 +1113,7 @@ subroutine depth_list_setup(G, US, CS) call create_depth_list(G, CS) endif - do k=1,G%ke + do k=1,GV%ke CS%lH(k) = CS%list_size enddo diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 8b50fe1acb..86482b9a03 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -151,7 +151,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: l_mono_N2_column_fraction, l_mono_N2_depth real :: mode_struct(SZK_(G)), ms_min, ms_max, ms_sq - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_wave_speed: "// & "Module must be initialized before it is used.") @@ -736,7 +736,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee integer :: sub, sub_it integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(CS)) then if (.not. associated(CS)) call MOM_error(FATAL, "MOM_wave_speed: "// & diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 88b062472f..c3a5b6ef46 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -180,7 +180,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo integer :: kc integer :: i, j, k, k2, 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke I_a_int = 1/a_int !if (present(CS)) then @@ -683,9 +683,10 @@ subroutine tridiag_solver(a, b, c, h, y, method, x) end subroutine tridiag_solver !> Allocate memory associated with the wave structure module and read parameters. -subroutine wave_structure_init(Time, G, param_file, diag, CS) +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 @@ -697,7 +698,7 @@ subroutine wave_structure_init(Time, G, param_file, diag, CS) 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 = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(WARNING, "wave_structure_init called with an "// & diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 28c4c867d7..55bde07b42 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -583,7 +583,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) !Define the downsampled axes call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) - call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, GV, diag_CS) end subroutine set_axes_info @@ -3584,9 +3584,10 @@ subroutine log_chksum_diag(docunit, description, chksum) end subroutine log_chksum_diag !> Allocates fields necessary to store diagnostic remapping fields -subroutine diag_grid_storage_init(grid_storage, G, diag) +subroutine diag_grid_storage_init(grid_storage, G, GV, diag) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids type(ocean_grid_type), intent(in) :: G !< Horizontal grid + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor !! template for this routine @@ -3597,7 +3598,7 @@ subroutine diag_grid_storage_init(grid_storage, G, diag) if (grid_storage%num_diag_coords < 1) return ! Allocate memory for the native space - allocate(grid_storage%h_state(G%isd:G%ied,G%jsd:G%jed, G%ke)) + allocate( grid_storage%h_state(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ! Allocate diagnostic remapping structures allocate(grid_storage%diag_grids(diag%num_diag_coords)) ! Loop through and allocate memory for the grid on each target coordinate diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 4e12abaa5b..08d60b20e4 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -327,7 +327,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then - call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & + call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & GV%Z_to_H*G%bathyT(i,j), 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 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 7972b51fe4..38788411b8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -177,7 +177,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -267,55 +267,55 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", & default="uniform", do_not_log=just_read) select case (trim(config)) - case ("file") - call initialize_thickness_from_file(h, G, GV, US, PF, .false., just_read_params=just_read) - case ("thickness_file") - call initialize_thickness_from_file(h, G, GV, US, PF, .true., just_read_params=just_read) - case ("coord") - if (new_sim .and. useALE) then - call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) - 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, G, GV, PF, & - just_read_params=just_read) - case ("list"); call initialize_thickness_list(h, G, GV, US, PF, & - just_read_params=just_read) - case ("DOME"); call DOME_initialize_thickness(h, G, GV, PF, & - just_read_params=just_read) - case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, US, PF, tv, & + case ("file") + call initialize_thickness_from_file(h, G, GV, US, PF, .false., just_read_params=just_read) + case ("thickness_file") + call initialize_thickness_from_file(h, G, GV, US, PF, .true., just_read_params=just_read) + case ("coord") + if (new_sim .and. useALE) then + call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) + 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, G, GV, PF, & just_read_params=just_read) - case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) - case ("Neverwoorld","Neverland"); call Neverworld_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, tv%P_Ref) - case ("search"); call initialize_thickness_search - case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & - just_read_params=just_read) - case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, US, & - PF, just_read_params=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, US, & - PF, just_read_params=just_read) - case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, US, PF, & + case ("list"); call initialize_thickness_list(h, G, GV, US, PF, & just_read_params=just_read) - case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, US, & - PF, just_read_params=just_read) - case ("sloshing"); call sloshing_initialize_thickness(h, G, GV, US, PF, & - just_read_params=just_read) - case ("seamount"); call seamount_initialize_thickness(h, G, GV, US, PF, & - just_read_params=just_read) - case ("dumbbell"); call dumbbell_initialize_thickness(h, G, GV, US, PF, & - just_read_params=just_read) - case ("soliton"); call soliton_initialize_thickness(h, G, GV, US) - case ("phillips"); call Phillips_initialize_thickness(h, G, GV, US, PF, & - just_read_params=just_read) - case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, US, & + case ("DOME"); call DOME_initialize_thickness(h, G, GV, PF, & + just_read_params=just_read) + case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, US, PF, tv, & + just_read_params=just_read) + case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & + tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) + case ("Neverwoorld","Neverland"); call Neverworld_initialize_thickness(h, G, GV, US, PF, & + tv%eqn_of_state, tv%P_Ref) + case ("search"); call initialize_thickness_search + case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & + just_read_params=just_read) + case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, US, & PF, just_read_params=just_read) - case ("USER"); call user_initialize_thickness(h, G, GV, PF, & - just_read_params=just_read) - case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& - "Unrecognized layer thickness configuration "//trim(config)) + case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, US, & + PF, just_read_params=just_read) + case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, US, PF, & + just_read_params=just_read) + case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, US, & + PF, just_read_params=just_read) + case ("sloshing"); call sloshing_initialize_thickness(h, G, GV, US, PF, & + just_read_params=just_read) + case ("seamount"); call seamount_initialize_thickness(h, G, GV, US, PF, & + just_read_params=just_read) + case ("dumbbell"); call dumbbell_initialize_thickness(h, G, GV, US, PF, & + just_read_params=just_read) + case ("soliton"); call soliton_initialize_thickness(h, G, GV, US) + case ("phillips"); call Phillips_initialize_thickness(h, G, GV, US, PF, & + just_read_params=just_read) + case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, US, & + PF, just_read_params=just_read) + case ("USER"); call user_initialize_thickness(h, G, GV, PF, & + just_read_params=just_read) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized layer thickness configuration "//trim(config)) end select ! Initialize temperature and salinity (T and S). @@ -345,13 +345,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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_params=just_read) - case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, & + case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, GV, & PF, just_read_params=just_read) case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & G, GV, US, PF, eos, tv%P_Ref, just_read_params=just_read) case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & - G, PF, just_read_params=just_read) - case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & + G, GV, PF, just_read_params=just_read) + case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, GV, PF, & just_read_params=just_read) case ("DOME2D"); call DOME2d_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) @@ -373,7 +373,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & G, GV, US, PF, just_read_params=just_read) case ("dense"); call dense_water_initialize_TS(G, GV, PF, eos, tv%T, tv%S, & h, just_read_params=just_read) - case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, PF, eos, & + case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, GV, PF, eos, & just_read_params=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized Temp & salt configuration "//trim(config)) @@ -381,7 +381,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif endif ! not from_Z_file. if (use_temperature .and. use_OBC) & - call fill_temp_salt_segments(G, OBC, tv) + call fill_temp_salt_segments(G, GV, OBC, tv) ! The thicknesses in halo points might be needed to initialize the velocities. if (new_sim) call pass_var(h, G%Domain) @@ -400,20 +400,20 @@ 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, US, PF, & + case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("zero"); call initialize_velocity_zero(u, v, G, PF, & + case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, & just_read_params=just_read) - case ("uniform"); call initialize_velocity_uniform(u, v, G, US, PF, & + case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("circular"); call initialize_velocity_circular(u, v, G, US, PF, & + case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, & just_read_params=just_read) case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & G, GV, US, PF, just_read_params=just_read) - case ("soliton"); call soliton_initialize_velocity(u, v, h, G, US) - case ("USER"); call user_initialize_velocity(u, v, G, US, PF, & + 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_params=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized velocity configuration "//trim(config)) @@ -586,17 +586,17 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & elseif (trim(config) == "shelfwave") then OBC%update_OBC = .true. elseif (lowercase(trim(config)) == "supercritical") then - call supercritical_set_OBC_data(OBC, G, PF) + call supercritical_set_OBC_data(OBC, G, GV, PF) elseif (trim(config) == "tidal_bay") then OBC%update_OBC = .true. elseif (trim(config) == "USER") then - call user_set_OBC_data(OBC, tv, G, PF, tracer_Reg) + call user_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) elseif (.not. trim(config) == "none") then call MOM_error(FATAL, "The open boundary conditions specified by "//& "OBC_USER_CONFIG = "//trim(config)//" have not been fully implemented.") endif if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) + call set_tracer_data(OBC, tv, h, G, GV, PF, tracer_Reg) endif endif ! if (open_boundary_query(OBC, apply_nudged_OBC=.true.)) then @@ -640,7 +640,7 @@ subroutine initialize_thickness_from_file(h, G, GV, US, param_file, file_has_thi character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -721,7 +721,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h) real :: hTmp, eTmp, dilate character(len=100) :: mesg - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke hTolerance = 0.1*US%m_to_Z contractions = 0 @@ -801,7 +801,7 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -859,7 +859,7 @@ subroutine initialize_thickness_list(h, G, GV, US, param_file, just_read_params) character(len=72) :: eta_var integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -941,7 +941,7 @@ subroutine convert_thickness(h, G, GV, US, tv) 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 = G%ke + 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 @@ -1017,7 +1017,7 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) character(len=200) :: filename, eta_srf_var ! Strings for file/path logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1150,7 +1150,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") - do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec T_t(i,j,k) = tv%T(i,j,k) ; T_b(i,j,k) = tv%T(i,j,k) S_t(i,j,k) = tv%S(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) enddo ; enddo ; enddo @@ -1268,8 +1268,9 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, end subroutine cut_off_column_top !> Initialize horizontal velocity components from file -subroutine initialize_velocity_from_file(u, v, G, US, param_file, just_read_params) +subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1309,8 +1310,9 @@ subroutine initialize_velocity_from_file(u, v, G, US, param_file, just_read_para end subroutine initialize_velocity_from_file !> Initialize horizontal velocity components to zero. -subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) +subroutine initialize_velocity_zero(u, v, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1323,7 +1325,7 @@ subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) character(len=200) :: mdl = "initialize_velocity_zero" ! This subroutine's name. logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1343,8 +1345,9 @@ subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) end subroutine initialize_velocity_zero !> Sets the initial velocity components to uniform -subroutine initialize_velocity_uniform(u, v, G, US, param_file, just_read_params) +subroutine initialize_velocity_uniform(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1359,7 +1362,7 @@ subroutine initialize_velocity_uniform(u, v, G, US, param_file, just_read_params real :: initial_u_const, initial_v_const logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: mdl = "initialize_velocity_uniform" ! This subroutine's name. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1384,8 +1387,9 @@ end subroutine initialize_velocity_uniform !> Sets the initial velocity components to be circular with !! no flow at edges of domain and center. -subroutine initialize_velocity_circular(u, v, G, US, param_file, just_read_params) +subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1402,7 +1406,7 @@ subroutine initialize_velocity_circular(u, v, G, US, param_file, just_read_param real :: psi1, psi2 ! Values of the streamfunction at two points [L2 T-1 ~> m2 s-1] logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1447,8 +1451,9 @@ end function my_psi end subroutine initialize_velocity_circular !> Initializes temperature and salinity from file -subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +subroutine initialize_temp_salt_from_file(T, S, G, GV, param_file, just_read_params) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is !! being initialized [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is @@ -1503,8 +1508,9 @@ subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) end subroutine initialize_temp_salt_from_file !> Initializes temperature and salinity from a 1D profile -subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_params) +subroutine initialize_temp_salt_from_profile(T, S, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is !! being initialized [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is @@ -1540,7 +1546,7 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para call MOM_read_data(filename, "PTEMP", T0(:)) call MOM_read_data(filename, "SALT", S0(:)) - do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + 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) enddo ; enddo ; enddo @@ -1576,7 +1582,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. integer :: i, j, k, itt, nz - nz = G%ke + nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1642,8 +1648,9 @@ end subroutine initialize_temp_salt_fit !! !! \remark Note that the linear distribution is set up with respect to the layer !! number, not the physical position). -subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read_params) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is !! being initialized [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is @@ -1682,24 +1689,24 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. ! Prescribe salinity -! delta_S = S_range / ( G%ke - 1.0 ) +! delta_S = S_range / ( GV%ke - 1.0 ) ! S(:,:,1) = S_top -! do k = 2,G%ke +! do k=2,GV%ke ! S(:,:,k) = S(:,:,k-1) + delta_S ! enddo - do k = 1,G%ke - S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(G%ke)) - T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(G%ke)) + 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 / ( G%ke - 1.0 ) +! delta_T = T_range / ( GV%ke - 1.0 ) ! T(:,:,1) = T_top -! do k = 2,G%ke +! do k=2,GV%ke ! T(:,:,k) = T(:,:,k-1) + delta_T ! enddo ! delta = 1 -! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0 +! T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -1752,7 +1759,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L ! time prior to vertical remapping. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed pres(:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 @@ -1882,7 +1889,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L 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)) enddo ; enddo ; enddo - call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) deallocate(eta) deallocate(h) if (use_temperature) then @@ -1895,7 +1902,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L endif else ! Initialize sponges without supplying sponge grid - call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) @@ -2066,7 +2073,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call cpu_clock_begin(id_clock_routine) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg @@ -2364,7 +2371,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml - call find_interfaces(rho_z, z_in, kd, Rb, G%bathyT, zi, G, US, & + call find_interfaces(rho_z, z_in, kd, Rb, G%bathyT, zi, G, GV, US, & nlevs, nkml, hml=Hmix_depth, eps_z=eps_z, eps_rho=eps_rho) if (correct_thickness) then @@ -2432,7 +2439,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! 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, & - missing_value, h, ks, G, US, eos) + missing_value, h, ks, G, GV, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) @@ -2449,9 +2456,10 @@ end subroutine MOM_temp_salt_initialize_from_Z !> Find interface positions corresponding to interpolated depths in a density profile -subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, hml, & +subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, GV, US, nlevs, nkml, hml, & eps_z, eps_rho) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: nk_data !< The number of levels in the input data real, dimension(SZI_(G),SZJ_(G),nk_data), & intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] @@ -2482,7 +2490,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, integer :: k_int, lo_int, hi_int, mid integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke zi(:,:,:) = 0.0 diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 1a4c5bd011..c349ab30b1 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -4,27 +4,17 @@ 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_coms, only : max_across_PEs, min_across_PEs 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_density_integrals, only : int_specific_vol_dp -use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast -use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +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, read_param, log_param, param_file_type -use MOM_file_parser, only : log_version -use MOM_get_input, only : directories -use MOM_grid, only : ocean_grid_type, isPointInCell +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_regridding, only : regridding_CS use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h -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, setVerticalGridAxes -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use MOM_verticalGrid, only : verticalGrid_type use MOM_ALE, only : ALE_remap_scalar implicit none ; private @@ -42,7 +32,7 @@ module MOM_tracer_initialization_from_Z contains -!> Initializes a tracer from a z-space data file. +!> 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 ) @@ -98,7 +88,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call cpu_clock_begin(id_clock_routine) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3f7f2ee548..ae84858234 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -167,7 +167,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h logical :: use_drag_rate ! Flag to indicate drag_rate is finite integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 (.not.associated(CS)) call MOM_error(FATAL, & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 3c63564a30..65d2c34d06 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -372,7 +372,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff @@ -1127,7 +1127,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%use_GME) then - call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G) + call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) call pass_vector(KH_u_GME, KH_v_GME, G%Domain) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1414,9 +1414,10 @@ end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). !! hor_visc_init calculates and stores the values of a number of metric functions that !! are used in horizontal_viscosity(). -subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) +subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. @@ -1479,7 +1480,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_hor_visc" ! module name - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -2083,30 +2084,30 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & ! v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then - ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) - ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) !endif !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & ! v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then - ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,G%ke) - ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) !endif CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then - call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) endif CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then - call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) endif if (CS%biharmonic) then diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 2bb3c3b0f1..37116fcae6 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2540,7 +2540,7 @@ 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, param_file, diag, CS%wave_structure_CSp) + call wave_structure_init(Time, G, GV, param_file, diag, CS%wave_structure_CSp) end subroutine internal_tides_init diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index c8406e8677..d0f81853e3 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -205,7 +205,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) integer :: power_2 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 = G%ke + 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 (.not. associated(CS)) call MOM_error(FATAL, "calc_resoln_function:"// & @@ -514,7 +514,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O if (.not. associated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_v is not associated with use_variable_mixing.") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke local_open_u_BC = .false. local_open_v_BC = .false. @@ -679,7 +679,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop if (.not. associated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_v is not associated with use_variable_mixing.") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke local_open_u_BC = .false. local_open_v_BC = .false. @@ -842,7 +842,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo 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 = G%ke + nz = GV%ke inv_PI3 = 1.0/((4.0*atan(1.0))**3) @@ -1059,7 +1059,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.",& units="m", default=2000., scale=US%m_to_Z) - allocate(CS%ebt_struct(isd:ied,jsd:jed,G%ke)) ; CS%ebt_struct(:,:,:) = 0.0 + allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke)) ; CS%ebt_struct(:,:,:) = 0.0 endif if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then @@ -1073,8 +1073,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%use_stored_slopes) then in_use = .true. - allocate(CS%slope_x(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%slope_x(:,:,:) = 0.0 - allocate(CS%slope_y(isd:ied,JsdB:JedB,G%ke+1)) ; CS%slope_y(:,:,:) = 0.0 + allocate(CS%slope_x(IsdB:IedB,jsd:jed,GV%ke+1)) ; CS%slope_x(:,:,:) = 0.0 + allocate(CS%slope_y(isd:ied,JsdB:JedB,GV%ke+1)) ; CS%slope_y(:,:,:) = 0.0 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.", & @@ -1313,8 +1313,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ALLOC_(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 ALLOC_(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 - ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,G%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 - ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,G%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 + ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 + ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 ! register diagnostics CS%id_KH_u_QG = register_diag_field('ocean_model', 'KH_u_QG', diag%axesCuL, Time, & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 37bbaa4230..1d28d58b55 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -194,7 +194,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var DD(z) = (1.-3.*(XP(z)**2)+2.*(XP(z)**3))**(1.+2.*CS%MLE_tail_dh) PSI(z) = max( PSI1(z), DD(z)*BOTTOP(z) ) ! Combines original PSI1 with tail - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & @@ -611,7 +611,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) 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, nkml - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nkml = GV%nkml if (.not. associated(CS)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 6ff0184d54..c83df84d4b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -165,7 +165,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if ((.not.CS%thickness_diffuse) .or. & .not.( CS%Khth > 0.0 .or. associated(VarMix) .or. associated(MEKE) ) ) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff if (associated(MEKE)) then @@ -693,7 +693,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV logical :: use_Stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; IsdB = G%IsdB I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) @@ -1567,7 +1567,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV logical, dimension(SZIB_(G)) :: & do_i ! If true, work on a column. integer :: i, j, k, n, ish, jsh, is, ie, js, je, nz, k_top - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke k_top = GV%nk_rho_varies + 1 h_neglect = GV%H_subroundoff @@ -2019,20 +2019,20 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) default=.false.) if (CS%use_GME_thickness_diffuse) then - call safe_alloc_ptr(CS%KH_u_GME,G%IsdB,G%IedB,G%jsd,G%jed,G%ke+1) - call safe_alloc_ptr(CS%KH_v_GME,G%isd,G%ied,G%JsdB,G%JedB,G%ke+1) + call safe_alloc_ptr(CS%KH_u_GME,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke+1) + call safe_alloc_ptr(CS%KH_v_GME,G%isd,G%ied,G%JsdB,G%JedB,GV%ke+1) endif CS%id_uhGM = register_diag_field('ocean_model', 'uhGM', diag%axesCuL, Time, & 'Time Mean Diffusive Zonal Thickness Flux', & 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & y_cell_method='sum', v_extensive=.true.) - if (CS%id_uhGM > 0) call safe_alloc_ptr(CDp%uhGM,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + if (CS%id_uhGM > 0) call safe_alloc_ptr(CDp%uhGM,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) CS%id_vhGM = register_diag_field('ocean_model', 'vhGM', diag%axesCvL, Time, & 'Time Mean Diffusive Meridional Thickness Flux', & 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & x_cell_method='sum', v_extensive=.true.) - if (CS%id_vhGM > 0) call safe_alloc_ptr(CDp%vhGM,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + if (CS%id_vhGM > 0) call safe_alloc_ptr(CDp%vhGM,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) CS%id_GMwork = register_diag_field('ocean_model', 'GMwork', diag%axesT1, Time, & 'Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & @@ -2067,10 +2067,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) CS%id_slope_x = register_diag_field('ocean_model', 'neutral_slope_x', diag%axesCui, Time, & 'Zonal slope of neutral surface', 'nondim') - if (CS%id_slope_x > 0) call safe_alloc_ptr(CS%diagSlopeX,G%IsdB,G%IedB,G%jsd,G%jed,G%ke+1) + if (CS%id_slope_x > 0) call safe_alloc_ptr(CS%diagSlopeX,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke+1) CS%id_slope_y = register_diag_field('ocean_model', 'neutral_slope_y', diag%axesCvi, Time, & 'Meridional slope of neutral surface', 'nondim') - if (CS%id_slope_y > 0) call safe_alloc_ptr(CS%diagSlopeY,G%isd,G%ied,G%JsdB,G%JedB,G%ke+1) + if (CS%id_slope_y > 0) call safe_alloc_ptr(CS%diagSlopeY,G%isd,G%ied,G%JsdB,G%JedB,GV%ke+1) CS%id_sfn_x = register_diag_field('ocean_model', 'GM_sfn_x', diag%axesCui, Time, & 'Parameterized Zonal Overturning Streamfunction', & 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) @@ -2087,10 +2087,10 @@ 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 -subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G) - type(thickness_diffuse_CS), pointer :: CS !< Control structure for - !! this module +subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) + type(thickness_diffuse_CS), pointer :: 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_(G)+1), intent(inout) :: KH_u_GME !< interface height !! diffusivities at u-faces [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: KH_v_GME !< interface height @@ -2098,11 +2098,11 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G) ! Local variables integer :: i,j,k - do k=1,G%ke+1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + do k=1,GV%ke+1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec KH_u_GME(I,j,k) = CS%KH_u_GME(I,j,k) enddo ; enddo ; enddo - do k=1,G%ke+1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + do k=1,GV%ke+1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec KH_v_GME(i,J,k) = CS%KH_v_GME(i,J,k) enddo ; enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 7ef0877321..09cd050a4a 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -145,9 +145,9 @@ module MOM_ALE_sponge !> This subroutine determines the number of points which are within sponges in this computational !! 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, param_file, CS, data_h, nz_data) - - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. +subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: nz_data !< The total number of sponge input layers. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: 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 @@ -213,7 +213,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "forms of the same expressions.", default=default_2018_answers) CS%time_varying_sponges = .false. - CS%nz = G%ke + CS%nz = GV%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed CS%iscB = G%iscB ; CS%iecB = G%iecB; CS%jscB = G%jscB ; CS%jecB = G%jecB @@ -389,8 +389,8 @@ end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are to be restoref in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. -subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) - +subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: 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 @@ -448,7 +448,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) "assumed to be on the model grid " , & default=.false.) CS%time_varying_sponges = .true. - CS%nz = G%ke + CS%nz = GV%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed CS%iscB = G%iscB ; CS%iecB = G%iecB; CS%jscB = G%jscB ; CS%jecB = G%jecB @@ -810,7 +810,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. integer :: nPoints - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return if (.not.CS%remap_answers_2018) then @@ -986,16 +986,17 @@ 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, 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. - type(ALE_sponge_CS), pointer :: sponge !< A pointer to the control that will be set up with - !! the new grid rotation - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure with the new rotation. - 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. +subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, 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. + type(ALE_sponge_CS), pointer :: sponge !< A pointer to the control that will be set up with + !! 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 + 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. ! First part: Index construction ! 1. Reconstruct Iresttime(:,:) from sponge_in @@ -1041,10 +1042,10 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) call rotate_array(Iresttime_in, turns, Iresttime) if (fixed_sponge) then call rotate_array(data_h_in, turns, data_h) - call initialize_ALE_sponge_fixed(Iresttime, G, param_file, sponge, & + call initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, sponge, & data_h, nz_data) else - call initialize_ALE_sponge_varying(Iresttime, G, param_file, sponge) + call initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, sponge) endif deallocate(Iresttime_in) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index ae650664b6..bfd0f77b38 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -625,11 +625,11 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & ! Local variables integer :: i, j, k ! Loop indices - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces [m2 s-1] - real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces [m2 s-1] - real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + 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] real :: surfFricVel, surfBuoyFlux real :: sigma, sigmaRatio @@ -674,7 +674,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & iFaceHeight(1) = 0.0 ! BBL is all relative to the surface hcorr = 0. - do k=1,G%ke + 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 @@ -714,12 +714,12 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & Kviscosity(:) = US%Z2_T_to_m2_s * Kv(i,j,:) endif - call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity [m2 s-1] + 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] - Kviscosity(:), & ! (in) Original viscosity [m2 s-1] + 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] @@ -728,12 +728,12 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & nonLocalTrans(:,2),& ! (out) Non-local salt transport [nondim] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] - G%ke, & ! (in) Number of levels to compute coeffs for - G%ke, & ! (in) Number of levels in array shape + GV%ke, & ! (in) Number of levels to compute coeffs for + GV%ke, & ! (in) Number of levels in array shape CVMix_kpp_params_user=CS%KPP_params ) ! safety check, Kviscosity and Kdiffusivity must be >= 0 - do k=1, G%ke+1 + do k=1, GV%ke+1 if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & "Negative vertical viscosity or diffusivity has been detected. " // & @@ -757,7 +757,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in LT_K_ENHANCEMENT") LangEnhK = 1.0 endif - do k=1,G%ke + do k=1,GV%ke if (CS%LT_K_SHAPE== LT_K_CONSTANT) then if (CS%id_EnhK > 0) CS%EnhK(i,j,:) = LangEnhK Kdiffusivity(k,1) = Kdiffusivity(k,1) * LangEnhK @@ -788,26 +788,26 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & ! and no spurious extrema. if (surfBuoyFlux < 0.0) then if (CS%NLT_shape == NLT_SHAPE_CUBIC) then - do k = 2, G%ke + do k = 2, GV%ke sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then - do k = 2, G%ke + do k = 2, GV%ke sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then - do k = 2, G%ke + do k = 2, GV%ke sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then ! Sanity check (should agree with CVMix result using simple matching) - do k = 2, G%ke + do k = 2, GV%ke sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 nonLocalTrans(k,2) = nonLocalTrans(k,1) @@ -833,7 +833,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & !BGR Now computing VT2 above so can modify for LT ! therefore, don't repeat this operation here ! CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & -! cellHeight(1:G%ke), & ! Depth of cell center [m] +! 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] ! CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters @@ -853,14 +853,14 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & ! Update output of routine if (.not. CS%passiveMode) then if (CS%KPPisAdditive) then - do k=1, G%ke+1 + 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) enddo else ! KPP replaces prior diffusivity when former is non-zero - do k=1, G%ke+1 + 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) @@ -919,20 +919,20 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Local variables integer :: i, j, k, km1 ! Loop indices - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] - real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] - real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] - real, dimension( G%ke ) :: surfBuoyFlux2 - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer + 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 ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] ! for EOS calculation - real, dimension( 3*G%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] - real, dimension( 3*G%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] - real, dimension( 3*G%ke ) :: Temp_1D - real, dimension( 3*G%ke ) :: Salt_1D + 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 [degC] + real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [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] @@ -954,8 +954,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! For Langmuir Calculations real :: LangEnhW ! Langmuir enhancement for turbulent velocity scale - real, dimension(G%ke) :: LangEnhVt2 ! Langmuir enhancement for unresolved shear - real, dimension(G%ke) :: U_H, V_H + real, dimension(GV%ke) :: LangEnhVt2 ! Langmuir enhancement for unresolved shear + real, dimension(GV%ke) :: U_H, V_H real :: MLD_GUESS, LA real :: surfHuS, surfHvS, surfUs, surfVs, wavedir, currentdir real :: VarUp, VarDn, M, VarLo, VarAvg @@ -994,7 +994,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! skip calling KPP for land points if (G%mask2dT(i,j)==0.) cycle - do k=1,G%ke + 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)) enddo @@ -1013,7 +1013,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl iFaceHeight(1) = 0.0 ! BBL is all relative to the surface pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) hcorr = 0. - do k=1,G%ke + 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 @@ -1123,7 +1123,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! N2 (can be negative) and N (non-negative) on interfaces. ! deltaRho is non-local rho difference used for bulk Richardson number. ! CS%N is local N (with floor) used for unresolved shear calculation. - do k = 1, G%ke + do k = 1, GV%ke km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) @@ -1131,8 +1131,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo - N2_1d(G%ke+1 ) = 0.0 - CS%N(i,j,G%ke+1 ) = 0.0 + N2_1d(GV%ke+1 ) = 0.0 + CS%N(i,j,GV%ke+1 ) = 0.0 ! 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 @@ -1148,7 +1148,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !Compute CVMix VT2 CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & - zt_cntr=cellHeight(1:G%ke), & ! Depth of cell center [m] + zt_cntr=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] CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters @@ -1156,25 +1156,25 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !Modify CVMix VT2 IF (CS%LT_VT2_ENHANCEMENT) then IF (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then - do k=1,G%ke + do k=1,GV%ke LangEnhVT2(k) = CS%KPP_VT2_ENH_FAC enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. enhvt2 = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & (5.4*CS%La_SL(i,j))**(-4)) - do k=1,G%ke + do k=1,GV%ke LangEnhVT2(k) = enhvt2 enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_RW16) then !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. enhvt2 = 1. + 2.3*CS%La_SL(i,j)**(-0.5) - do k=1,G%ke + do k=1,GV%ke LangEnhVT2(k) = enhvt2 enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_LF17) then CS%CS=cvmix_get_kpp_real('c_s',CS%KPP_params) - do k=1,G%ke + do k=1,GV%ke WST = (max(0.,-buoy_scale*buoyflux(i,j,1))*(-cellHeight(k)))**(1./3.) LangEnhVT2(k) = sqrt((0.15*WST**3. + 0.17*surfFricVel**3.* & (1.+0.49*CS%La_SL(i,j)**(-2.))) / & @@ -1189,14 +1189,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl LangEnhVT2(:) = 1.0 endif - do k=1,G%ke + do k=1,GV%ke CS%Vt2(i,j,k)=CS%Vt2(i,j,k)*LangEnhVT2(k) if (CS%id_EnhVt2 > 0) CS%EnhVt2(i,j,k)=LangEnhVT2(k) enddo ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & - zt_cntr = cellHeight(1:G%ke), & ! Depth of cell center [m] + zt_cntr = cellHeight(1:GV%ke), & ! Depth of cell center [m] delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [s-1] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] Vt_sqr_cntr=CS%Vt2(i,j,:), & @@ -1221,14 +1221,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! 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(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%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) = 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(G%ke+1) ) ! no deeper than bottom + 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) ) @@ -1290,9 +1290,9 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) ! local real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] ! (negative in the ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] + 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 real :: dh ! The local thickness used for calculating interface positions [m] @@ -1321,7 +1321,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) iFaceHeight(1) = 0.0 ! BBL is all relative to the surface hcorr = 0. - do k=1,G%ke + 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 @@ -1349,7 +1349,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) ! prevent OBL depths deeper than the bathymetric depth - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + 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 enddo @@ -1405,7 +1405,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & dtracer(:,:,:) = 0.0 !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & @@ -1417,7 +1417,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then !$OMP parallel do default(none) shared(dt, scalar, dtracer, G) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) @@ -1432,7 +1432,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & if (CS%id_NLT_temp_budget > 0) then dtracer(:,:,:) = 0.0 !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, surfFlux, C_p, G, GV) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * & @@ -1466,7 +1466,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, dtracer(:,:,:) = 0.0 !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & @@ -1478,7 +1478,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then !$OMP parallel do default(none) shared(G, dt, scalar, dtracer) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) @@ -1493,7 +1493,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, if (CS%id_NLT_saln_budget > 0) then dtracer(:,:,:) = 0.0 !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux) - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * & @@ -1507,8 +1507,6 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, end subroutine KPP_NonLocalTransport_saln - - !> Clear pointers, deallocate memory subroutine KPP_end(CS) type(KPP_CS), pointer :: CS !< Control structure diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index ee6762f5f5..e487e616af 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -200,7 +200,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) pres_int(1) = 0. ; if (associated(tv%p_surf)) pres_int(1) = tv%p_surf(i,j) ! we don't have SST and SSS, so let's use values at top-most layer temp_int(1) = tv%T(i,j,1); salt_int(1) = tv%S(i,j,1) - do K=2,G%ke + do K=2,GV%ke ! pressure at interface pres_int(K) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k-1) ! temp and salt at interface @@ -217,13 +217,13 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! The "-1.0" below is needed so that the following criteria is satisfied: ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" - do k=1,G%ke + do k=1,GV%ke alpha_dT(k) = -1.0*US%R_to_kg_m3*drho_dT(k) * dT(k) beta_dS(k) = US%R_to_kg_m3*drho_dS(k) * dS(k) enddo if (present(R_rho)) then - do k=1,G%ke + do k=1,GV%ke ! Set R_rho using Adcroft's rule of reciprocals. R_rho(i,j,k) = 0.0 ; if (abs(beta_dS(k)) > 0.0) R_rho(i,j,k) = alpha_dT(k) / beta_dS(k) ! avoid NaN's again for safety, perhaps unnecessarily. @@ -234,7 +234,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) iFaceHeight(1) = 0.0 ! BBL is all relative to the surface hcorr = 0.0 ! compute heights at cell center and interfaces - do k=1,G%ke + do k=1,GV%ke dh = h(i,j,k) * GV%H_to_m ! 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 @@ -251,9 +251,9 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) Sdiff_out=Kd1_S(:), & strat_param_num=alpha_dT(:), & strat_param_denom=beta_dS(:), & - nlev=G%ke, & - max_nlev=G%ke) - do K=1,G%ke+1 + 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) enddo diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index e969d9a640..1df0390697 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -81,13 +81,13 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) 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(2*(G%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] - real, dimension(2*(G%ke)) :: temp_1d ! A column of temperatures [degC] - real, dimension(2*(G%ke)) :: salt_1d ! A column of salinities [ppt] - real, dimension(2*(G%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] - real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] - real, dimension(G%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] - real, dimension(G%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] + 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 [degC] + real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [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) :: 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] ! some constants @@ -103,7 +103,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) ! Richardson number computed for each cell in a column. pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) Ri_Grad(:)=1.e8 !Initialize w/ large Richardson value - do k=1,G%ke + do k=1,GV%ke ! pressure, temp, and saln for EOS ! kk+1 = k fields ! kk+2 = km1 fields @@ -126,7 +126,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state) ! N2 (can be negative) on interface - do k = 1, G%ke + do k = 1, GV%ke km1 = max(1, k-1) kk = 2*(k-1) DU = u_h(i,j,k) - u_h(i,j,km1) @@ -143,22 +143,22 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) enddo - Ri_grad(G%ke+1) = Ri_grad(G%ke) + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) if (CS%smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value - do k = 2, G%ke + do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) enddo - Ri_grad(G%ke+1) = Ri_grad(G%ke) + 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(G%ke+1) = Ri_grad(G%ke) - do k = 3, G%ke + 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) enddo @@ -166,7 +166,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) endif - do K=1,G%ke+1 + 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) enddo @@ -175,9 +175,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) call CVMix_coeffs_shear(Mdiff_out=Kvisc(:), & Tdiff_out=Kdiff(:), & RICH=Ri_Grad(:), & - nlev=G%ke, & - max_nlev=G%ke) - do K=1,G%ke+1 + 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) enddo diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 756e67f244..c3ee727573 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -343,7 +343,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [Z2 T-1 ~> m2 s-1] integer :: i, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! set some parameters deg_to_rad = atan(1.0)/45.0 ! = PI/180 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1683e21fbe..1ee3fb4563 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -127,7 +127,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) ! row of points. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo endif @@ -260,7 +260,7 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) real :: b_denom_S ! for b1_T and b1_S, both [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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff !$OMP parallel do default(private) shared(is,ie,js,je,h,h_neglect,dt,Kd_T,Kd_S,G,GV,T,S,nz) @@ -336,7 +336,7 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) real :: mc !< A layer's mass [R Z ~> kg m-2]. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo endif @@ -410,7 +410,7 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) T(i,j,1) = (b1(i)*h_tr)*T(i,j,1) S(i,j,1) = (b1(i)*h_tr)*S(i,j,1) enddo - do k=2,G%ke ; do i=is,ie + do k=2,GV%ke ; do i=is,ie c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = hold(i,j,k) + GV%H_subroundoff b_denom_1 = h_tr + d1(i)*ea(i,j,k) @@ -419,7 +419,7 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) T(i,j,k) = b1(i) * (h_tr*T(i,j,k) + ea(i,j,k)*T(i,j,k-1)) S(i,j,k) = b1(i) * (h_tr*S(i,j,k) + ea(i,j,k)*S(i,j,k-1)) enddo ; enddo - do k=G%ke-1,1,-1 ; do i=is,ie + do k=GV%ke-1,1,-1 ; do i=is,ie T(i,j,k) = T(i,j,k) + c1(i,k+1)*T(i,j,k+1) S(i,j,k) = S(i,j,k) + c1(i,k+1)*S(i,j,k+1) enddo ; enddo @@ -458,7 +458,7 @@ subroutine triDiagTS_Eulerian(G, GV, is, ie, js, je, hold, ent, T, S) T(i,j,1) = (b1(i)*h_tr)*T(i,j,1) S(i,j,1) = (b1(i)*h_tr)*S(i,j,1) enddo - do k=2,G%ke ; do i=is,ie + do k=2,GV%ke ; do i=is,ie c1(i,k) = ent(i,j,K) * b1(i) h_tr = hold(i,j,k) + GV%H_subroundoff b_denom_1 = h_tr + d1(i)*ent(i,j,K) @@ -467,7 +467,7 @@ subroutine triDiagTS_Eulerian(G, GV, is, ie, js, je, hold, ent, T, S) T(i,j,k) = b1(i) * (h_tr*T(i,j,k) + ent(i,j,K)*T(i,j,k-1)) S(i,j,k) = b1(i) * (h_tr*S(i,j,k) + ent(i,j,K)*S(i,j,k-1)) enddo ; enddo - do k=G%ke-1,1,-1 ; do i=is,ie + do k=GV%ke-1,1,-1 ; do i=is,ie T(i,j,k) = T(i,j,k) + c1(i,k+1)*T(i,j,k+1) S(i,j,k) = S(i,j,k) + c1(i,k+1)*S(i,j,k+1) enddo ; enddo @@ -699,7 +699,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, gE_rho0 = US%L_to_Z**2*GV%g_Earth / (GV%Rho0) dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pRef_MLD(:) = 0.0 EOSdom(:) = EOS_domain(G%HI) @@ -835,7 +835,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) integer :: IT, iM integer :: i, j, is, ie, js, je, k, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pRef_MLD(:) = 0.0 mld(:,:,:) = 0.0 @@ -1084,7 +1084,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t integer :: i, j, is, ie, js, je, k, nz, n, nb character(len=45) :: mesg - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 1.0 / dt @@ -1569,7 +1569,7 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori character(len=32) :: chl_varname ! Name of chl_a variable in chl_file. logical :: use_temperature ! True if thermodynamics are enabled. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (associated(CS)) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2fb6a27542..b720fc9694 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3410,7 +3410,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif ! Initialize the diagnostic grid storage - call diag_grid_storage_init(CS%diag_grids_prev, G, diag) + call diag_grid_storage_init(CS%diag_grids_prev, G, GV, diag) end subroutine diabatic_driver_init diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index a83b18bf2f..0515f81725 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -72,7 +72,7 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real :: tmp1 ! A temporary array. integer :: i, j, k, is, ie, js, je, nz, itt logical :: may_print - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "diapyc_energy_req_test: "// & "Module must be initialized before it is used.") @@ -260,7 +260,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & integer :: k, nz, itt, max_itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug logical :: old_PE_calc - nz = G%ke + nz = GV%ke h_neglect = GV%H_subroundoff debug = .true. diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 4ed0dcc6bf..ee04b841c4 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -203,7 +203,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & integer :: kb_min ! The minimum value of kb in the current j-row. integer :: kb_min_act ! The minimum active value of kb in the current j-row. integer :: is1, ie1 ! The minimum and maximum active values of i in the current j-row. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Angstrom = GV%Angstrom_H h_neglect = GV%H_subroundoff @@ -781,7 +781,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo else ! not bulkmixedlayer - do k=K2,nz-1; + do k=K2,nz-1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than @@ -931,7 +931,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke if (present(do_i_in)) then do i=is,ie ; do_i(i) = do_i_in(i) ; enddo @@ -1075,7 +1075,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, ! in roundoff and can be neglected [H ~> m or kg m-2]. 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 = G%ke + 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 diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 3be6628b14..d9c0a76b43 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -94,7 +94,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, else is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec endif - nz = G%ke + nz = GV%ke if (.not.associated(tv%eqn_of_state)) return @@ -360,7 +360,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else is = G%isc ; ie = G%iec endif - nz = G%ke + nz = GV%ke h_neglect = GV%H_subroundoff kap_dt_x2 = 2.0*Kddt diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 2ecaa4a78e..ceadaff821 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -122,7 +122,7 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) integer :: i, j, k, is, ie, js, je, nz, k2, i2 integer :: isj, iej, num_left, nkmb, k_tgt - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo endif @@ -400,7 +400,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) logical :: calc_diags ! True if diagnostic tendencies are needed. integer :: i, j, k, is, ie, js, je, nz, i2, isj, iej - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index f5b9e7dbb7..9ab9a7fc34 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -99,7 +99,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& @@ -184,7 +184,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) 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 = G%ke + 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 EOSdom(:) = EOS_domain(G%HI) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 7cbbc33441..cbd2731d39 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -460,7 +460,7 @@ subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_ ! Local variables real :: scale_opacity, scale_penSW ! Rescaling factors integer :: i, is, ie, k, nz, n - is = G%isc ; ie = G%iec ; nz = G%ke + 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 @@ -611,7 +611,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l I_Habs = optics%PenSW_absorb_Invlen h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke C1_6 = 1.0 / 6.0 ; C1_60 = 1.0 / 60.0 TKE_calc = (present(TKE) .and. present(dSV_dT)) @@ -835,7 +835,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & I_Habs = 1e3*GV%H_to_m ! optics%PenSW_absorb_Invlen h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke pen_SW_bnd(:,:) = iPen_SW_bnd(:,:) do i=is,ie ; h_heat(i) = 0.0 ; enddo @@ -943,7 +943,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) logical :: default_2018_answers logical :: use_scheme integer :: isd, ied, jsd, jed, nz, n - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(WARNING, "opacity_init called with an associated"// & diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index f21faa359d..625b6e34c4 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -91,7 +91,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) ! Local variables integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -192,7 +192,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, nkmb, nkml, k1, k2, k3, ks, nz_filt, kmax_d_ea - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -656,7 +656,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, nkmb - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 7b5dcc2be5..774d050f33 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -284,7 +284,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [Z2 ~> m2] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("set_diffusivity(), MOM_set_diffusivity.F90") @@ -355,7 +355,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif ! set up arrays for tidal mixing diagnostics - call setup_tidal_diagnostics(G, CS%tidal_mixing_CSp) + call setup_tidal_diagnostics(G, GV, CS%tidal_mixing_CSp) if (CS%useKappaShear) then if (CS%debug) then @@ -760,7 +760,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz, i_rem, kmb, kb_min - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke I_dt = 1.0 / dt Omega2 = CS%omega**2 @@ -964,7 +964,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & 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 = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) H_neglect = GV%H_subroundoff @@ -1127,7 +1127,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) 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 = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke if (associated(tv%eqn_of_state)) then do i=is,ie @@ -1239,7 +1239,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & logical :: do_diag_Kd_BBL integer :: i, k, is, ie, nz, i_rem, kb_min - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke do_diag_Kd_BBL = associated(Kd_BBL) @@ -1510,7 +1510,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input ! at the bottom. - do k=G%ke,2,-1 + 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]. @@ -1612,7 +1612,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, TKE_to_Kd, Kd_lay, logical :: do_any, do_i(SZI_(G)) integer :: i, k, is, ie, nz, kml - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 @@ -1765,7 +1765,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) local_open_v_BC = OBC%open_v_BCs_exist_globally endif ; endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) call MOM_error(FATAL,"set_BBL_TKE: "//& "Module must be initialized before it is used.") @@ -1932,7 +1932,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, k3, is, ie, nz, kmb - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke do k=2,nz-1 if (GV%g_prime(k+1) /= 0.0) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index a7bb80afc9..8d4704f516 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -353,7 +353,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) integer :: itt, maxitt=20 type(ocean_OBC_type), pointer :: OBC => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff @@ -1323,7 +1323,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n type(ocean_OBC_type), pointer :: OBC => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index dcd0ac4e02..11951e6f0c 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -133,7 +133,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & CS%do_i_mean_sponge = present(Iresttime_i_mean) - CS%nz = G%ke + CS%nz = GV%ke ! CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec ! CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed ! CS%bulkmixedlayer may be set later via a call to set_up_sponge_ML_density. @@ -169,7 +169,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & if (CS%do_i_mean_sponge) then allocate(CS%Iresttime_im(G%jsd:G%jed)) ; CS%Iresttime_im(:) = 0.0 - allocate(CS%Ref_eta_im(G%jsd:G%jed,G%ke+1)) ; CS%Ref_eta_im(:,:) = 0.0 + allocate(CS%Ref_eta_im(G%jsd:G%jed,GV%ke+1)) ; CS%Ref_eta_im(:,:) = 0.0 do j=G%jsc,G%jec CS%Iresttime_im(j) = Iresttime_i_mean(j) @@ -382,7 +382,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) real :: damp_1pdamp ! damp_1pdamp is damp/(1 + damp). [nondim] real :: Idt ! 1.0/dt times a height unit conversion factor [m H-1 T-1 ~> s-1 or m3 kg-1 s-1]. integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return if (CS%bulkmixedlayer) nkmb = GV%nk_rho_varies diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index bf70067675..9401b06662 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -761,7 +761,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv iFaceHeight = 0.0 ! BBL is all relative to the surface hcorr = 0.0 - do k=1,G%ke + 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 = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) @@ -771,7 +771,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv iFaceHeight(k+1) = iFaceHeight(k) - dh enddo - call CVMix_compute_Simmons_invariant( nlev = G%ke, & + call CVMix_compute_Simmons_invariant( nlev = GV%ke, & energy_flux = CS%tidal_qe_2d(i,j), & rho = rho_fw, & SimmonsCoeff = Simmons_coeff, & @@ -787,35 +787,35 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do K=1,G%ke+1 + do K=1,GV%ke+1 N2_int_i(K) = US%s_to_T**2 * N2_int(i,K) enddo - call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & - Tdiff_out = Kd_tidal, & - Nsqr = N2_int_i, & - OceanDepth = -iFaceHeight(G%ke+1),& - SimmonsCoeff = Simmons_coeff, & - vert_dep = vert_dep, & - nlev = G%ke, & - max_nlev = G%ke, & - CVMix_params = CS%CVMix_glb_params, & + call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & + Tdiff_out = Kd_tidal, & + Nsqr = N2_int_i, & + OceanDepth = -iFaceHeight(GV%ke+1),& + SimmonsCoeff = Simmons_coeff, & + vert_dep = vert_dep, & + nlev = GV%ke, & + max_nlev = GV%ke, & + CVMix_params = CS%CVMix_glb_params, & CVMix_tidal_params_user = CS%CVMix_tidal_params) ! Update diffusivity if (present(Kd_lay)) then - do k=1,G%ke + 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)) enddo endif if (present(Kd_int)) then - do K=1,G%ke+1 + do K=1,GV%ke+1 Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then - do K=1,G%ke+1 + 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. enddo endif @@ -841,7 +841,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! TODO: correct exp_hab_zetar shapes in CVMix_compute_Schmittner_invariant ! and CVMix_compute_SchmittnerCoeff low subroutines - allocate(exp_hab_zetar(G%ke+1,G%ke+1)) + allocate(exp_hab_zetar(GV%ke+1,GV%ke+1)) do i=is,ie @@ -849,7 +849,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv iFaceHeight = 0.0 ! BBL is all relative to the surface hcorr = 0.0 - do k=1,G%ke + 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) @@ -862,7 +862,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv SchmittnerSocn = 0.0 ! TODO: compute this ! form the time-invariant part of Schmittner coefficient term - call CVMix_compute_Schmittner_invariant(nlev = G%ke, & + call CVMix_compute_Schmittner_invariant(nlev = GV%ke, & VertDep = vert_dep, & efficiency = CS%Mu_itides, & rho = rho_fw, & @@ -876,11 +876,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! remap from input z coordinate to model coordinate: 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,:), & - G%ke, h_m, tidal_qe_md) + GV%ke, h_m, tidal_qe_md) ! 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 = G%ke, & + call CVMix_compute_SchmittnerCoeff( nlev = GV%ke, & energy_flux = tidal_qe_md(:), & rho = rho_fw, & SchmittnerCoeff = Schmittner_coeff, & @@ -888,17 +888,17 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv CVmix_tidal_params_user = CS%CVMix_tidal_params) ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k=1,G%ke+1 + do k=1,GV%ke+1 N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) enddo call CVMix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & Nsqr = N2_int_i, & - OceanDepth = -iFaceHeight(G%ke+1), & + OceanDepth = -iFaceHeight(GV%ke+1), & vert_dep = vert_dep, & - nlev = G%ke, & - max_nlev = G%ke, & + nlev = GV%ke, & + max_nlev = GV%ke, & SchmittnerCoeff = Schmittner_coeff, & SchmittnerSouthernOcean = SchmittnerSocn, & CVmix_params = CS%CVMix_glb_params, & @@ -906,19 +906,19 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! Update diffusivity if (present(Kd_lay)) then - do k=1,G%ke + 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)) enddo endif if (present(Kd_int)) then - do K=1,G%ke+1 + do K=1,GV%ke+1 Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity if (associated(Kv)) then - do K=1,G%ke+1 + 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. enddo endif @@ -1034,7 +1034,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, integer :: a, fr, m type(tidal_mixing_diags), pointer :: dd => NULL() - is = G%isc ; ie = G%iec ; nz = G%ke + is = G%isc ; ie = G%iec ; nz = GV%ke dd => CS%dd if (.not.(CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation)) return @@ -1409,15 +1409,16 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, end subroutine add_int_tide_diffusivity !> Sets up diagnostics arrays for tidal mixing. -subroutine setup_tidal_diagnostics(G,CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(tidal_mixing_cs), pointer :: CS !< The control structure for this module +subroutine setup_tidal_diagnostics(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(tidal_mixing_cs), pointer :: CS !< The control structure for this module ! local integer :: isd, ied, jsd, jed, nz type(tidal_mixing_diags), pointer :: dd => NULL() - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = GV%ke dd => CS%dd if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_Itidal_work > 0)) then @@ -1585,10 +1586,10 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidalinputs type(tidal_mixing_cs), pointer :: CS !< The control structure for this module ! local - integer :: i, j, isd, ied, jsd, jed, nz + 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 ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed select case (uppercase(tidal_energy_type(1:4))) case ('JAYN') ! Jayne 2009 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 7786bf5b46..a41a47b254 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -218,7 +218,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n 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 = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") @@ -534,7 +534,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") @@ -690,7 +690,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! finding z_clear. 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 = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & "Module must be initialized before it is used.") @@ -701,11 +701,11 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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) then - allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) ; Kv_u(:,:,:) = 0.0 + allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ; Kv_u(:,:,:) = 0.0 endif if (CS%id_Kv_v > 0) then - allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) ; Kv_v(:,:,:) = 0.0 + allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) ; Kv_v(:,:,:) = 0.0 endif if (CS%debug .or. (CS%id_hML_u > 0)) then @@ -1155,7 +1155,7 @@ 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 = G%ke + nz = GV%ke h_neglect = GV%H_subroundoff if (CS%answers_2018) then @@ -1394,7 +1394,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS real :: v_old(SZI_(G),SZJB_(G),SZK_(G)) ! The previous v-velocity [L T-1 ~> m s-1] logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + 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 maxvel = CS%maxvel @@ -1614,7 +1614,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (GV%Boussinesq) then; thickness_units = "m" else; thickness_units = "kg m-2"; endif - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + 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 CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 5503287c50..349154cfe6 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -184,7 +184,7 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 @@ -283,7 +283,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 9aad84a6dd..cdcd121a2c 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -345,12 +345,12 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) & call init_tracer_CFC(h, CS%CFC11, CS%CFC11_name, CS%CFC11_land_val, & - CS%CFC11_IC_val, G, US, CS) + CS%CFC11_IC_val, G, GV, US, CS) if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) & call init_tracer_CFC(h, CS%CFC12, CS%CFC12_name, CS%CFC12_land_val, & - CS%CFC12_IC_val, G, US, CS) + CS%CFC12_IC_val, G, GV, US, CS) if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. @@ -359,8 +359,9 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & end subroutine initialize_OCMIP2_CFC !>This subroutine initializes a tracer array. -subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, US, CS) +subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr !< The tracer concentration array @@ -374,16 +375,16 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, US, CS) logical :: OK integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (len_trim(CS%IC_file) > 0) then ! Read the tracer concentrations from a netcdf file. if (.not.file_exists(CS%IC_file, G%Domain)) & call MOM_error(FATAL, "initialize_OCMIP2_CFC: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then - OK = tracer_Z_init(tr, h, CS%IC_file, name, G, US) + OK = tracer_Z_init(tr, h, CS%IC_file, name, G, GV, US) if (.not.OK) then - OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G, US) + OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G, GV, US) if (.not.OK) call MOM_error(FATAL,"initialize_OCMIP2_CFC: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 1ecf9629d8..29a575af77 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -252,14 +252,14 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, 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:G%ke) :: grid_tmask - integer, dimension(G%isd:G%ied, G%jsd:G%jed) :: grid_kmt + 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 !! 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. !! Ideally, the generic tracer IC file should have the tracers on Z levels. - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke CS%diag=>diag !Get the tracer list @@ -322,9 +322,9 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, US) + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, US) + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& "Unable to read "//trim(g_tracer_name)//" from "//& trim(CS%IC_file)//".") @@ -364,7 +364,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, do j = G%jsd, G%jed ; do i = G%isd, G%ied if (G%mask2dT(i,j) > 0) then grid_tmask(i,j,:) = 1.0 - grid_kmt(i,j) = G%ke ! Tell the code that a layer thicker than 1m is the bottom layer. + grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif enddo ; enddo call g_tracer_set_common(G%isc,G%iec,G%jsc,G%jec,G%isd,G%ied,G%jsd,G%jed,& @@ -434,11 +434,11 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] real :: sosga - real, dimension(G%isd:G%ied,G%jsd:G%jed,G%ke) :: rho_dzt, dzt + real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke) :: rho_dzt, dzt real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work integer :: i, j, k, isc, iec, jsc, jec, nk - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke !Get the tracer list if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& @@ -588,7 +588,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke MOM_generic_tracer_stock = 0 if (.not.associated(CS)) return @@ -663,10 +663,10 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - integer :: i, j, k, is, ie, js, je, nz, m + integer :: i, j, k, is, ie, js, je, m real, allocatable, dimension(:) :: geo_z - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec MOM_generic_tracer_min_max = 0 if (.not.associated(CS)) return @@ -716,8 +716,9 @@ end function MOM_generic_tracer_min_max !! !! This subroutine sets up the fields that the coupler needs to calculate the !! CFC fluxes between the ocean and atmosphere. - subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) + subroutine MOM_generic_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -727,8 +728,8 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) real :: sosga character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt + 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 type(g_tracer_type), pointer :: g_tracer !Set coupler values diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 465174f676..547385c5b5 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -158,8 +158,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport - real, dimension(SZI_(G),SZJ_(G),G%ke) :: tendency !< tendency array for diagn - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostics + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagnostics type(tracer_type), pointer :: Tracer => NULL() !< Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m !< indices to loop over @@ -182,7 +182,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Interpolate state to interface do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & + call build_reconstructions_1d( CS%remap_CS, GV%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e64f5f69ce..5d5acf3e1b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -113,9 +113,10 @@ module MOM_neutral_diffusion contains !> Read parameters and allocate control structure for neutral_diffusion module. -logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diabatic_CSp, CS) +logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, 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 !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -244,11 +245,11 @@ logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diab ! units="m2 s-1", default=0.0) ! call closeParameterBlock(param_file) if (CS%continuous_reconstruction) then - CS%nsurf = 2*G%ke+2 ! Continuous reconstruction means that every interface has two connections + CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections allocate(CS%dRdT(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%dRdT(:,:,:) = 0. allocate(CS%dRdS(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%dRdS(:,:,:) = 0. else - CS%nsurf = 4*G%ke ! Discontinuous means that every interface has four connections + CS%nsurf = 4*GV%ke ! Discontinuous means that every interface has four connections allocate(CS%T_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%T_i(:,:,:,:) = 0. allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%S_i(:,:,:,:) = 0. allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%P_i(:,:,:,:) = 0. @@ -323,7 +324,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) call pass_var(hbl, G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - 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, GV%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) enddo; enddo ! TODO: add similar code for BOTTOM boundary layer endif @@ -361,7 +362,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) else CS%Pint(:,:,1) = 0. endif - do k=1,G%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*(GV%g_Earth*GV%H_to_RZ) enddo ; enddo ; enddo @@ -379,7 +380,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) CS%P_i(i,j,1,2) = h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) enddo ; enddo endif - do k=2,G%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + do k=2,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 CS%P_i(i,j,k,1) = CS%P_i(i,j,k-1,2) CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) enddo ; enddo ; enddo @@ -390,16 +391,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Interpolate state to interface do i = G%isc-1, G%iec+1 if (CS%continuous_reconstruction) then - call interface_scalar(G%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2, h_neglect) - call interface_scalar(G%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2, h_neglect) + call interface_scalar(GV%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2, h_neglect) + call interface_scalar(GV%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2, h_neglect) else - call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), T(i,j,:), CS%ppoly_coeffs_T(i,j,:,:), & + call build_reconstructions_1d( CS%remap_CS, GV%ke, h(i,j,:), T(i,j,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%T_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) - call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), S(i,j,:), CS%ppoly_coeffs_S(i,j,:,:), & + call build_reconstructions_1d( CS%remap_CS, GV%ke, h(i,j,:), S(i,j,:), CS%ppoly_coeffs_S(i,j,:,:), & CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the ! polynomial reconstructions - do k=1,G%ke + do k=1,GV%ke CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) CS%S_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 0. ) @@ -410,13 +411,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Continuous reconstruction if (CS%continuous_reconstruction) then - do k = 1, G%ke+1 + do k = 1, GV%ke+1 if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, CS%dRdT(:,j,k), & CS%dRdS(:,j,k), CS%EOS, EOSdom) enddo else ! Discontinuous reconstruction - do k = 1, G%ke + do k = 1, GV%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) ! Calculate derivatives for the top interface call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, CS%dRdT_i(:,j,k,1), & @@ -431,7 +432,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) if (.not. CS%continuous_reconstruction) then do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 - call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) + call mark_unstable_cells( CS, GV%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) if (CS%interior_only) then if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. ! set values in the surface and bottom boundary layer to false. @@ -457,13 +458,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) do j = G%jsc, G%jec ; do I = G%isc-1, G%iec if (G%mask2dCu(I,j) > 0.) then if (CS%continuous_reconstruction) then - call find_neutral_surface_positions_continuous(G%ke, & + call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) else - call find_neutral_surface_positions_discontinuous(CS, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, GV%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & @@ -478,13 +479,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) do J = G%jsc-1, G%jec ; do i = G%isc, G%iec if (G%mask2dCv(i,J) > 0.) then if (CS%continuous_reconstruction) then - call find_neutral_surface_positions_continuous(G%ke, & + call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) else - call find_neutral_surface_positions_discontinuous(CS, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, GV%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & @@ -542,11 +543,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) 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(SZI_(G),SZJ_(G),G%ke) :: tendency ! tendency array for diagn + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency ! tendency array for diagn real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn 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(G%ke) :: dTracer ! change in tracer concentration due to ndiffusion + real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 3895e8a116..7b1ae7bb2d 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -336,7 +336,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock call hchksum(h_vol,"h_vol before advect",G%HI) call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI) write(debug_msg, '(A,I4.4)') 'Before advect ', iter - call MOM_tracer_chkinv(debug_msg, G, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, CS%dt_offline, G, GV, CS%US, & @@ -357,7 +357,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock if (CS%debug) then call hchksum(h_new,"h_new before ALE",G%HI) write(debug_msg, '(A,I4.4)') 'Before ALE ', iter - call MOM_tracer_chkinv(debug_msg, G, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_begin(id_clock_ALE) call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%dt_offline) @@ -366,7 +366,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock if (CS%debug) then call hchksum(h_new,"h_new after ALE",G%HI) write(debug_msg, '(A,I4.4)') 'After ALE ', iter - call MOM_tracer_chkinv(debug_msg, G, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif endif @@ -408,7 +408,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock if (CS%debug) then call hchksum(h_pre,"h after offline_advection_ale",G%HI) call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI) - call MOM_tracer_chkinv("After offline_advection_ale", G, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_end(CS%id_clock_offline_adv) @@ -476,7 +476,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) if (converged) return if (CS%debug) then - call MOM_tracer_chkinv("Before redistribute ", G, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("Before redistribute ", G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_begin(CS%id_clock_redistribute) @@ -607,7 +607,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) if (CS%debug) then call hchksum(h_pre,"h_pre after redistribute",G%HI) call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI) - call MOM_tracer_chkinv("after redistribute ", G, h_new, CS%tracer_Reg%Tr, CS%tracer_Reg%ntr) + call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg%Tr, CS%tracer_Reg%ntr) endif call cpu_clock_end(CS%id_clock_redistribute) @@ -683,7 +683,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e call hchksum(h_pre,"h_pre before offline_diabatic_ale",CS%G%HI) call hchksum(eatr,"eatr before offline_diabatic_ale",CS%G%HI) call hchksum(ebtr,"ebtr before offline_diabatic_ale",CS%G%HI) - call MOM_tracer_chkinv("Before offline_diabatic_ale", CS%G, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("Before offline_diabatic_ale", CS%G, CS%GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif eatr(:,:,:) = 0. @@ -747,7 +747,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e call hchksum(h_pre,"h_pre after offline_diabatic_ale",CS%G%HI) call hchksum(eatr,"eatr after offline_diabatic_ale",CS%G%HI) call hchksum(ebtr,"ebtr after offline_diabatic_ale",CS%G%HI) - call MOM_tracer_chkinv("After offline_diabatic_ale", CS%G, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("After offline_diabatic_ale", CS%G, CS%GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_end(CS%id_clock_offline_diabatic) @@ -786,8 +786,8 @@ 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) - call MOM_tracer_chkinv("Before fluxes into ocean", G, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h before fluxes into ocean", G%HI) + call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif do m = 1,CS%tracer_reg%ntr ! Layer thicknesses should only be updated after the last tracer is finished @@ -796,8 +796,8 @@ 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) - call MOM_tracer_chkinv("After fluxes into ocean", G, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h after fluxes into ocean", G%HI) + call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif ! Now that fluxes into the ocean are done, save the negative fluxes for later @@ -825,7 +825,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) if (CS%debug) then call hchksum(h,"h before fluxes out of ocean",G%HI) - call MOM_tracer_chkinv("Before fluxes out of ocean", G, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif do m = 1, CS%tracer_reg%ntr ! Layer thicknesses should only be updated after the last tracer is finished @@ -835,7 +835,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) enddo if (CS%debug) then call hchksum(h,"h after fluxes out of ocean",G%HI) - call MOM_tracer_chkinv("Before fluxes out of ocean", G, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif end subroutine offline_fw_fluxes_out_ocean diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index ac6242785e..17b34e210e 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -9,6 +9,7 @@ module MOM_tracer_Z_init use MOM_io, only : MOM_read_data use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type use netcdf @@ -27,9 +28,10 @@ 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, US, missing_val, land_val) +function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val) 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_(G)), & intent(out) :: tr !< The tracer to initialize @@ -75,7 +77,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke landval = 0.0 ; if (present(land_val)) landval = land_val @@ -610,8 +612,10 @@ 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, land_fill, h, k_start, G, US, eos, h_massless) +subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, G, GV, US, & + eos, 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_(G)), & intent(inout) :: temp !< potential temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -651,7 +655,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, kz, is, ie, js, je, nz, itt - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! These hard coded parameters need to be set properly. S_min = 0.5 ; S_max = 65.0 diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 6b9a12f696..67b7ef0497 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -466,7 +466,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim integer :: i, j, is, ie, js, je, k, nz, n, nsw character(len=45) :: mesg - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! If no freshwater fluxes, nothing needs to be done in this routine if ( (.not. associated(fluxes%netMassIn)) .or. (.not. associated(fluxes%netMassOut)) ) return diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 4c7c27c7e6..88d42ad2b2 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -722,10 +722,11 @@ end subroutine store_stocks !> This subroutine calls all registered tracer packages to enable them to !! add to the surface state returned to the coupler. These routines are optional. -subroutine call_tracer_surface_state(sfc_state, h, G, CS) +subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a @@ -752,7 +753,7 @@ subroutine call_tracer_surface_state(sfc_state, h, G, CS) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_surface_state(sfc_state, h, G, CS%OCMIP2_CFC_CSp) if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_surface_state(sfc_state, h, G, CS%MOM_generic_tracer_CSp) + call MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS%MOM_generic_tracer_CSp) end subroutine call_tracer_surface_state diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 43ede7cff5..0159e3add2 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1430,9 +1430,10 @@ end subroutine tracer_epipycnal_ML_diff !> Initialize lateral tracer diffusion module -subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp, CS) +subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic_CSp, 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 !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< diagnostic control type(EOS_type), target, intent(in) :: EOS !< Equation of state CS @@ -1507,7 +1508,7 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, US, param_file, diag, EOS, & + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, & 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!") diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cb8f1716fe..cec419d068 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -371,7 +371,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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 - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 @@ -695,7 +695,7 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) real :: work(SZI_(G),SZJ_(G),SZK_(G)) real :: Idt ! The inverse of the time step [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz, m, m2 - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! The "if" is to avoid NaNs if the diagnostic is called for a zero length interval Idt = 0.0 ; if (dt /= 0.0) Idt = 1.0 / dt @@ -729,7 +729,7 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) real :: Idt ! The inverse of the time step [T-1 ~> s-1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval @@ -779,7 +779,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) real :: work2d(SZI_(G),SZJ_(G)) type(tracer_type), pointer :: Tr=>NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) @@ -811,10 +811,8 @@ subroutine MOM_tracer_chksum(mesg, Tr, ntr, G) integer, intent(in) :: ntr !< number of registered tracers type(ocean_grid_type), intent(in) :: G !< ocean grid structure - integer :: is, ie, js, je, nz - integer :: i, j, k, m + integer :: m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke do m=1,ntr call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI) enddo @@ -822,9 +820,10 @@ subroutine MOM_tracer_chksum(mesg, Tr, ntr, G) end subroutine MOM_tracer_chksum !> Calculates and prints the global inventory of all tracers in the registry. -subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) +subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) character(len=*), intent(in) :: mesg !< message that appears on the chksum lines type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses integer, intent(in) :: ntr !< number of registered tracers @@ -834,7 +833,7 @@ subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) integer :: is, ie, js, je, nz integer :: i, j, k, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke do m=1,ntr do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%US%L_to_m**2*G%areaT(i,j)*G%mask2dT(i,j) diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 44c6c2e5a1..9d0b5e4f74 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -191,7 +191,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & integer :: nzdata if (.not.associated(CS)) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 @@ -307,7 +307,7 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 8f00b0d5b9..f6d98b1f0f 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -250,10 +250,10 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name,& - G, US, -1e34, 0.0) ! CS%land_val(m)) + G, GV, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & - trim(name), G, US, -1e34, 0.0) ! CS%land_val(m)) + trim(name), G, GV, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) call MOM_error(FATAL,"initialize_ideal_age_tracer: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index c07f1c03e4..12427b7c37 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -265,10 +265,10 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name, & - G, US, -1e34, 0.0) ! CS%land_val(m)) + G, GV, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & - trim(name), G, US, -1e34, 0.0) ! CS%land_val(m)) + trim(name), G, GV, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) call MOM_error(FATAL,"initialize_oil_tracer: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 5465d5fcea..48708794fd 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -98,7 +98,7 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para 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 = G%ke + 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 diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 923801db2d..46425cbb0d 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -114,7 +114,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, US, param_file, just_read_par logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -245,7 +245,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, character(len=40) :: verticalCoordinate real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -303,9 +303,9 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, case ( REGRIDDING_LAYER ) - delta_S = S_range / ( G%ke - 1.0 ) + delta_S = S_range / ( GV%ke - 1.0 ) S(:,:,1) = S_ref - do k = 2,G%ke + do k = 2,GV%ke S(:,:,k) = S(:,:,k-1) + delta_S enddo @@ -317,7 +317,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, ! Modify salinity and temperature when z coordinates are used if ( coordinateMode(verticalCoordinate) == REGRIDDING_ZSTAR ) then - index_bay_z = Nint ( dome2d_depth_bay * G%ke ) + index_bay_z = Nint ( dome2d_depth_bay * GV%ke ) do j = G%jsc,G%jec ; do i = G%isc,G%iec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -332,20 +332,20 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, 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:G%ke) = S_ref + S_range; ! Use for sigma coordinates - T(i,j,1:G%ke) = 1.0; ! Use for sigma coordinates + S(i,j,1:GV%ke) = S_ref + S_range; ! Use for sigma coordinates + T(i,j,1:GV%ke) = 1.0; ! Use for sigma coordinates endif enddo ; enddo endif ! Modify temperature when rho coordinates are used - T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0 + T(G%isc:G%iec,G%jsc:G%jec,1:GV%ke) = 0.0 if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then 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,G%ke) = 1.0 + T(i,j,GV%ke) = 1.0 endif enddo ; enddo endif @@ -381,7 +381,7 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC real :: dummy1, x, z 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 = G%ke + 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 call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_TIME_SCALE", dome2d_west_sponge_time_scale, & @@ -463,7 +463,7 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC enddo enddo ; enddo ! Store the grid on which the T/S sponge data will reside - call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) + 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 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index f92d2d7ac6..e994518eff 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -105,7 +105,7 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) character(len=40) :: mdl = "DOME_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -168,7 +168,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) character(len=40) :: mdl = "DOME_initialize_sponges" ! 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 = G%ke + 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 ; temp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 @@ -281,7 +281,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index d125495d7f..4ffe8bdc35 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -157,7 +157,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -285,7 +285,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi real :: drho_dT1 ! A prescribed derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: T_Ref, S_Ref - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pres(:) = 0.0 just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -462,7 +462,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) character(len=40) :: mdl = "ISOMIP_initialize_sponges" ! 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 = G%ke + 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 call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, "Minimum layer thickness", & @@ -589,7 +589,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! 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, PF, ACSp, h, nz) + 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 diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 227c814b3c..0a46fb260d 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -194,7 +194,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: val1, val2, sina, cosa type(OBC_segment_type), pointer :: segment => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index da181c5eca..daedacf4b2 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -369,9 +369,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Allocate and initialize ! a. Stokes driftProfiles - allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,GV%ke)) CS%Us_x(:,:,:) = 0.0 - allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,GV%ke)) CS%Us_y(:,:,:) = 0.0 ! b. Surface Values allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) @@ -385,7 +385,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%La_turb (:,:) = 0.0 ! d. Viscosity for Stokes drift if (CS%StokesMixing) then - allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) + allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,GV%ke)) CS%KvS(:,:,:) = 0.0 endif @@ -502,7 +502,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) IIm1 = max(1,II-1) Bottom = 0.0 MidPoint = 0.0 - do kk = 1,G%ke + 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)) @@ -515,7 +515,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) JJm1 = max(1,JJ-1) Bottom = 0.0 MidPoint = 0.0 - do kk = 1,G%ke + 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)) @@ -549,7 +549,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo ! 2. Second compute the level averaged Stokes drift bottom = 0.0 - do kk = 1,G%ke + do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) @@ -592,7 +592,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo ! Compute the level averages. bottom = 0.0 - do kk = 1,G%ke + 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)) @@ -624,7 +624,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do II = G%isdB,G%iedB do jj = G%jsd,G%jed bottom = 0.0 - do kk = 1,G%ke + do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) @@ -642,7 +642,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do ii = G%isd,G%ied do JJ = G%jsdB,G%jedB Bottom = 0.0 - do kk=1, G%ke + 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)) @@ -664,7 +664,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) DHH85_is_set = .true. endif else! Keep this else, fallback to 0 Stokes drift - do kk= 1,G%ke + do kk= 1,GV%ke do II = G%isdB,G%iedB do jj = G%jsd,G%jed CS%Us_x(II,jj,kk) = 0. @@ -921,7 +921,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & endif ContinueLoop = .true. bottom = 0.0 - do kk = 1,G%ke + 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) @@ -933,7 +933,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & endif if (WaveMethod==TESTPROF) then - do kk = 1,G%ke + 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)) enddo @@ -1238,7 +1238,7 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) ! This is a template to think about down-Stokes mixing. ! This is not ready for use... - do k = 1, G%ke + 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)) @@ -1248,7 +1248,7 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) (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)) )) dTauDn = 0.0 - if (k < G%ke-1) & + if (k < GV%ke-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)) )) @@ -1257,7 +1257,7 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) enddo enddo - do k = 1, G%ke + 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)) @@ -1267,7 +1267,7 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) (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)) )) dTauDn = 0.0 - if (k < G%ke-1) & + if (k < GV%ke-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)) )) @@ -1303,7 +1303,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) real :: DVel ! A rescaled velocity change [m s-1 T-1 ~> m s-2] integer :: i,j,k - do k = 1, G%ke + do k = 1, GV%ke do j = G%jsc, G%jec do I = G%iscB, G%iecB DVel = 0.25*(WAVES%us_y(i,j+1,k)+WAVES%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & @@ -1313,7 +1313,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) enddo enddo - do k = 1, G%ke + do k = 1, GV%ke do J = G%jscB, G%jecB do i = G%isc, G%iec DVel = 0.25*(WAVES%us_x(i+1,j,k)+WAVES%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index d019854310..4c095c0b63 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -264,7 +264,7 @@ subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_stat character(len=40) :: mdl = "Neverworld_initialize_thickness" ! 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call MOM_mesg(" Neverworld_initialization.F90, Neverworld_initialize_thickness: setting thickness", 5) call get_param(param_file, mdl, "INIT_THICKNESS_PROFILE", h_profile, & diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index dd7309265f..6bbe429248 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -58,7 +58,7 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par character(len=40) :: mdl = "Phillips_initialize_thickness" ! 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 = G%ke + 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_im(:,:) = 0.0 @@ -139,7 +139,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p integer :: i, j, k, is, ie, js, je, nz, m logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "Phillips_initialize_velocity" ! This subroutine's name. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -233,7 +233,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz logical, save :: first_call = .true. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed eta(:,:,:) = 0.0 ; temp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 70b9fcd4dc..6fbe90b855 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -48,10 +48,10 @@ module RGC_initialization !> Sets up the the inverse restoration time, and the values towards which the interface heights, !! velocities and tracers should be restored within the sponges for the RGC test case. subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) - type(ocean_grid_type), intent(in) :: G !< The ocean's 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + 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. @@ -93,7 +93,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB @@ -181,8 +181,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) call read_data(filename,h_var,h(:,:,:), domain=G%Domain%mpp_domain) call pass_var(h, G%domain) - !call initialize_ALE_sponge(Idamp, h, nz, G, PF, ACSp) - call initialize_ALE_sponge(Idamp, G, PF, ACSp, h, nz) + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) ! The remaining calls to set_up_sponge_field can be in any order. ! if ( associated(tv%T) ) then diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 1238944a60..4e27227da6 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -54,7 +54,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -129,7 +129,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & character(len=40) :: verticalCoordinate real :: PI ! 3.1415926... calculated as 4*atan(1) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -189,7 +189,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 9f36e7033d..1d426be636 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -76,7 +76,7 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read_par logical :: just_read ! If true, just read parameters but set nothing. 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 = G%ke + 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 diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 0ceaabbec7..66cbf7e72d 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -61,7 +61,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read #include "version_variable.h" integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -220,7 +220,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, G, GV, param_file logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index b1977b3fdd..4415f6bcae 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -96,7 +96,7 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, GV, US, param_f real :: PI ! 3.1415926... calculated as 4*atan(1) logical :: just_read ! If true, just read parameters but set nothing. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, dTdz, & diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index cc82ea6761..243e31bc4d 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -126,7 +126,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state character(len=40) :: mdl = "benchmark_initialize_thickness" ! 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params if (.not.just_read) call log_version(param_file, mdl, version, "") @@ -242,7 +242,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index eb7f765890..4dd5a7c606 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -31,7 +31,7 @@ module circle_obcs_initialization subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. @@ -50,7 +50,7 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para character(len=40) :: mdl = "circle_obcs_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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 468a5649fe..9c9952a102 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -249,7 +249,7 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CS enddo enddo - call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) ! construct temperature and salinity for the sponge ! start with initial condition diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 2b2b8b46c6..c0979def10 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -114,7 +114,7 @@ subroutine dumbbell_initialize_thickness ( h, G, GV, US, param_file, just_read_p logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -228,7 +228,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file logical :: dbrotate ! If true, rotate the domain. character(len=20) :: verticalCoordinate, density_profile - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -366,7 +366,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, enddo enddo ; enddo - call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) ! construct temperature and salinity for the sponge ! start with initial condition diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index da4751b3fa..4c633ebdc9 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -131,12 +131,13 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) end subroutine dyed_channel_set_OBC_tracer_data !> This subroutine updates the long-channel flow -subroutine dyed_channel_update_flow(OBC, CS, G, Time) +subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel 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(time_type), intent(in) :: Time !< model time. ! Local variables character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. @@ -166,7 +167,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, Time) else flow = G%US%m_s_to_L_T*CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) endif - do k=1,G%ke + do k=1,GV%ke do j=jsd,jed ; do I=IsdB,IedB if (segment%specified .or. segment%nudged) then segment%normal_vel(I,j,k) = flow diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 39519ce8a6..0307d93d3d 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -45,7 +45,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 2ef3ca2fb7..96a5ec40d0 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -47,7 +47,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re integer :: i, j, k, is, ie, js, je, nz real :: PI, Xnondim - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 1a3e8dd308..d56605aa63 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -47,7 +47,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea character(len=40) :: mdl = "lock_exchange_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 0df24efb42..684f22fb0a 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -99,7 +99,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, US, param_file, just_read_p logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -210,7 +210,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate, density_profile - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 928c8ae223..7ab923dfea 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -13,6 +13,7 @@ module shelfwave_initialization use MOM_open_boundary, only : OBC_registry_type use MOM_time_manager, only : time_type, time_type_to_real use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -125,14 +126,15 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) end subroutine shelfwave_initialize_topography !> This subroutine sets the properties of flow at open boundary conditions. -subroutine shelfwave_set_OBC_data(OBC, CS, G, h, Time) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies +subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. - type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(shelfwave_OBC_CS), pointer :: CS !< tidal bay 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_(G)), intent(in) :: h !< layer thickness. - type(time_type), intent(in) :: Time !< model 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, time_sec diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 5136775918..4a91435cb6 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -79,7 +79,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p integer :: i, j, k, is, ie, js, je, nx, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params if (.not.just_read) call log_version(param_file, mdl, version, "") @@ -203,7 +203,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file 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 = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -221,10 +221,10 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file if (just_read) return ! All run-time parameters have been read, so return. ! Prescribe salinity - !delta_S = S_range / ( G%ke - 1.0 ) + !delta_S = S_range / ( GV%ke - 1.0 ) !S(:,:,1) = S_ref - !do k = 2,G%ke + !do k = 2,GV%ke ! S(:,:,k) = S(:,:,k-1) + delta_S !enddo @@ -239,14 +239,14 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file enddo ; enddo ! Prescribe temperature - delta_T = T_range / ( G%ke - 1.0 ) + delta_T = T_range / ( GV%ke - 1.0 ) T(:,:,1) = T_ref - do k = 2,G%ke + do k = 2,GV%ke T(:,:,k) = T(:,:,k-1) + delta_T enddo kdelta = 2 - T(:,:,G%ke/2 - (kdelta-1):G%ke/2 + kdelta) = 1.0 + T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = 1.0 end subroutine sloshing_initialize_temperature_salinity diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 4351060fb8..4d75a25695 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -40,7 +40,7 @@ subroutine soliton_initialize_thickness(h, G, GV, US) real :: val1, val2, val3, val4 character(len=40) :: verticalCoordinate - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") @@ -63,8 +63,9 @@ end subroutine soliton_initialize_thickness !> Initialization of u and v in the equatorial Rossby soliton test -subroutine soliton_initialize_velocity(u, v, h, G, US) +subroutine soliton_initialize_velocity(u, v, h, 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_(G)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H ~> m or kg m-2] @@ -79,7 +80,7 @@ subroutine soliton_initialize_velocity(u, v, h, G, US) real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke x0 = 2.0*G%len_lon/3.0 y0 = 0.0 diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 19aacab72d..12a31f3a75 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -23,12 +23,13 @@ module supercritical_initialization contains !> This subroutine sets the properties of flow at open boundary conditions. -subroutine supercritical_set_OBC_data(OBC, G, param_file) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(param_file_type), intent(in) :: param_file !< Parameter file structure +subroutine supercritical_set_OBC_data(OBC, G, GV, param_file) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + 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 !< Parameter file structure ! Local variables character(len=40) :: mdl = "supercritical_set_OBC_data" ! This subroutine's name. real :: zonal_flow ! Inflow speed [L T-1 ~> m s-1] @@ -52,7 +53,7 @@ subroutine supercritical_set_OBC_data(OBC, G, param_file) if (segment%is_E_or_W) then jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - do k=1,G%ke + do k=1,GV%ke do j=jsd,jed ; do I=IsdB,IedB if (segment%specified .or. segment%nudged) then segment%normal_vel(I,j,k) = zonal_flow diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 67999fff40..f2efc4cefc 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -60,14 +60,15 @@ subroutine tidal_bay_OBC_end(CS) end subroutine tidal_bay_OBC_end !> This subroutine sets the properties of flow at open boundary conditions. -subroutine tidal_bay_set_OBC_data(OBC, CS, G, h, Time) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay control structure. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. +subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay 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_(G)), intent(in) :: h !< layer thickness. - type(time_type), intent(in) :: Time !< model 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, cff @@ -79,7 +80,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, h, Time) integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = 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 diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index a63e7a2b89..222bc1b6f2 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -80,7 +80,7 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i real :: dt_fill ! timestep used to fill massless layers character(len=200) :: mesg - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed if (.not.associated(CS)) call MOM_error(FATAL,"user_set_diffusivity: "//& diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index a5d0fc90f7..671663fd74 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -105,8 +105,9 @@ subroutine USER_initialize_thickness(h, G, GV, param_file, just_read_params) end subroutine USER_initialize_thickness !> initialize velocities. -subroutine USER_initialize_velocity(u, v, G, US, param_file, just_read_params) +subroutine USER_initialize_velocity(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] real, dimension(SZI_(G), SZJB_(G), SZK_(G)), 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 @@ -135,8 +136,9 @@ end subroutine USER_initialize_velocity !> This function puts the initial layer temperatures and salinities !! into T(:,:,:) and S(:,:,:). -subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state, just_read_params) +subroutine USER_init_temperature_salinity(T, S, G, GV, param_file, eqn_of_state, just_read_params) 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_(G)), intent(out) :: T !< Potential temperature [degC]. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt]. type(param_file_type), intent(in) :: param_file !< A structure indicating the @@ -188,7 +190,7 @@ subroutine USER_initialize_sponges(G, GV, use_temp, tv, param_file, CSp, h) end subroutine USER_initialize_sponges !> This subroutine sets the properties of flow at open boundary conditions. -subroutine USER_set_OBC_data(OBC, tv, G, param_file, tr_Reg) +subroutine USER_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -197,6 +199,7 @@ subroutine USER_set_OBC_data(OBC, tv, G, param_file, tr_Reg) !! 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(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. From 9b333433fa846dc489eb07d92266c8795593a8ac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Dec 2020 18:28:45 -0500 Subject: [PATCH 065/212] +Replace SZK_(G) with SZK_(GV) Use the vertical extent from the verticalGrid_type argument GV instead of the extent from the ocean_grid_type argument G to specify the vertical extent of arrays in memory in array declarations. There 18 subroutines where new vertical_grid_type arguqments were needed, and some comments were corrected. All answers are bitwise identical, but there are new (non-optional) arguments to 18 subroutines. --- config_src/unit_drivers/MOM_sum_driver.F90 | 26 +-- src/core/MOM.F90 | 12 +- src/core/MOM_CoriolisAdv.F90 | 38 ++-- src/core/MOM_PressureForce.F90 | 8 +- src/core/MOM_PressureForce_FV.F90 | 58 +++--- src/core/MOM_PressureForce_Montgomery.F90 | 90 ++++----- src/core/MOM_barotropic.F90 | 46 ++--- src/core/MOM_boundary_update.F90 | 16 +- src/core/MOM_checksum_packages.F90 | 40 ++-- src/core/MOM_continuity.F90 | 20 +- src/core/MOM_continuity_PPM.F90 | 142 +++++++------- src/core/MOM_dynamics_split_RK2.F90 | 45 ++--- src/core/MOM_dynamics_unsplit.F90 | 26 +-- src/core/MOM_dynamics_unsplit_RK2.F90 | 26 +-- src/core/MOM_forcing_type.F90 | 26 +-- src/core/MOM_interface_heights.F90 | 18 +- src/core/MOM_isopycnal_slopes.F90 | 52 ++--- src/core/MOM_open_boundary.F90 | 64 +++--- src/diagnostics/MOM_PointAccel.F90 | 28 +-- src/diagnostics/MOM_diagnostics.F90 | 40 ++-- src/diagnostics/MOM_sum_output.F90 | 24 +-- src/diagnostics/MOM_wave_speed.F90 | 22 +-- src/diagnostics/MOM_wave_structure.F90 | 26 +-- .../MOM_state_initialization.F90 | 151 ++++++++------- .../MOM_tracer_initialization_from_Z.F90 | 2 +- src/ocean_data_assim/MOM_oda_driver.F90 | 7 +- src/parameterizations/lateral/MOM_MEKE.F90 | 6 +- .../lateral/MOM_hor_visc.F90 | 20 +- .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 82 ++++---- .../lateral/MOM_mixed_layer_restrat.F90 | 102 +++++----- .../lateral/MOM_thickness_diffuse.F90 | 182 +++++++++--------- .../vertical/MOM_ALE_sponge.F90 | 42 ++-- .../vertical/MOM_CVMix_KPP.F90 | 82 ++++---- .../vertical/MOM_CVMix_conv.F90 | 6 +- .../vertical/MOM_CVMix_shear.F90 | 18 +- .../vertical/MOM_diabatic_aux.F90 | 114 +++++------ .../vertical/MOM_entrain_diffusive.F90 | 76 ++++---- .../vertical/MOM_full_convection.F90 | 28 +-- .../vertical/MOM_geothermal.F90 | 77 ++++---- .../vertical/MOM_internal_tide_input.F90 | 58 +++--- .../vertical/MOM_regularize_layers.F90 | 26 +-- .../vertical/MOM_set_diffusivity.F90 | 114 +++++------ .../vertical/MOM_set_viscosity.F90 | 84 ++++---- src/parameterizations/vertical/MOM_sponge.F90 | 41 ++-- .../vertical/MOM_tidal_mixing.F90 | 100 +++++----- .../vertical/MOM_vert_friction.F90 | 26 +-- src/tracer/DOME_tracer.F90 | 35 ++-- src/tracer/ISOMIP_tracer.F90 | 32 ++- src/tracer/MOM_OCMIP2_CFC.F90 | 53 +++-- src/tracer/MOM_generic_tracer.F90 | 16 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 +- src/tracer/MOM_neutral_diffusion.F90 | 44 ++--- src/tracer/MOM_offline_aux.F90 | 82 ++++---- src/tracer/MOM_offline_main.F90 | 70 +++---- src/tracer/MOM_tracer_Z_init.F90 | 16 +- src/tracer/MOM_tracer_advect.F90 | 41 ++-- src/tracer/MOM_tracer_diabatic.F90 | 6 +- src/tracer/MOM_tracer_flow_control.F90 | 23 +-- src/tracer/MOM_tracer_hor_diff.F90 | 20 +- src/tracer/MOM_tracer_registry.F90 | 18 +- src/tracer/RGC_tracer.F90 | 19 +- src/tracer/advection_test_tracer.F90 | 33 ++-- src/tracer/boundary_impulse_tracer.F90 | 29 +-- src/tracer/dye_example.F90 | 27 +-- src/tracer/dyed_obc_tracer.F90 | 15 +- src/tracer/ideal_age_example.F90 | 33 ++-- src/tracer/oil_tracer.F90 | 31 +-- src/tracer/pseudo_salt_tracer.F90 | 31 +-- src/tracer/tracer_example.F90 | 21 +- src/user/DOME2d_initialization.F90 | 30 +-- src/user/DOME_initialization.F90 | 21 +- src/user/ISOMIP_initialization.F90 | 45 ++--- src/user/Kelvin_initialization.F90 | 2 +- src/user/MOM_wave_interface.F90 | 16 +- src/user/Neverworld_initialization.F90 | 4 +- src/user/Phillips_initialization.F90 | 14 +- src/user/RGC_initialization.F90 | 45 ++--- src/user/Rossby_front_2d_initialization.F90 | 12 +- src/user/adjustment_initialization.F90 | 18 +- src/user/baroclinic_zone_initialization.F90 | 6 +- src/user/benchmark_initialization.F90 | 21 +- src/user/dense_water_initialization.F90 | 4 +- src/user/dumbbell_initialization.F90 | 12 +- src/user/external_gwave_initialization.F90 | 8 +- src/user/seamount_initialization.F90 | 11 +- src/user/shelfwave_initialization.F90 | 2 +- src/user/sloshing_initialization.F90 | 14 +- src/user/soliton_initialization.F90 | 12 +- src/user/tidal_bay_initialization.F90 | 2 +- src/user/user_change_diffusivity.F90 | 14 +- src/user/user_initialization.F90 | 8 +- 92 files changed, 1677 insertions(+), 1690 deletions(-) diff --git a/config_src/unit_drivers/MOM_sum_driver.F90 b/config_src/unit_drivers/MOM_sum_driver.F90 index 5673b201ee..7e3c6d45b4 100644 --- a/config_src/unit_drivers/MOM_sum_driver.F90 +++ b/config_src/unit_drivers/MOM_sum_driver.F90 @@ -18,8 +18,6 @@ program MOM_main use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT -! use MOM_diag_mediator, only : diag_mediator_end, diag_mediator_init -! use MOM_diag_mediator, only : diag_mediator_close_registration use MOM_domains, only : MOM_domains_init, MOM_infra_init, MOM_infra_end use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe use MOM_error_handler, only : MOM_set_verbosity @@ -39,11 +37,10 @@ program MOM_main type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. - real :: max_depth + real :: max_depth ! The maximum ocean depth [m] integer :: verbosity integer :: num_sums - integer :: n, i, j, is, ie, js, je, nz - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: n, i, j, is, ie, js, je, isd, ied, jsd, jed integer :: unit, io_status, ierr logical :: unit_in_use @@ -55,8 +52,8 @@ program MOM_main !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' -! 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_main (MOM_sum_driver)" ! This module's name. character(len=200) :: mesg @@ -85,9 +82,8 @@ program MOM_main ! call diag_mediator_init(param_file) call MOM_grid_init(grid, param_file) - is = grid%isc ; ie = grid%iec ; js = grid%jsc ; je = grid%jec ; nz = grid%ke + is = grid%isc ; ie = grid%iec ; js = grid%jsc ; je = grid%jec isd = grid%isd ; ied = grid%ied ; jsd = grid%jsd ; jed = grid%jed - IsdB = grid%IsdB ; IedB = grid%IedB ; JsdB = grid%JsdB ; JedB = grid%JedB ! Read all relevant parameters and write them to the model log. call log_version(param_file, "MOM", version, "") @@ -165,27 +161,25 @@ program MOM_main contains +!> This subroutine sets up the benchmark test case topography for debugging subroutine benchmark_init_topog_local(D, G, param_file, max_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D !< The 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 in m + real, intent(in) :: max_depth !< The maximum ocean depth [m] -! This subroutine sets up the benchmark test case topography 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 :: x, y -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "benchmark_initialize_topography" ! This subroutine's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "benchmark_init_topog_local" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call MOM_mesg(" benchmark_initialization.F90, benchmark_initialize_topography: setting topography", 5) - 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) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4da7f66e85..ddd6fe6dbb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1133,7 +1133,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thicknesses after the transports [H ~> m or kg m-2] type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. @@ -1214,11 +1214,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables type(forcing), intent(inout) :: fluxes !< pointers to forcing fields @@ -1247,7 +1247,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call enable_averages(dtdia, Time_end_thermo, CS%diag) if (associated(CS%odaCS)) then - call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) + call apply_oda_tracer_increments(US%T_to_s*dtdia, G, GV, tv, h, CS%odaCS) endif if (associated(fluxes%p_surf) .or. associated(fluxes%p_surf_full)) then @@ -2800,7 +2800,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) if (CS%write_IC) then allocate(restart_CSp_tmp) restart_CSp_tmp = restart_CSp - allocate(z_interface(SZI_(G),SZJ_(G),SZK_(G)+1)) + 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) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 10a6ecf3ac..becf3c422e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -114,23 +114,23 @@ module MOM_CoriolisAdv !> Calculates the Coriolis and momentum advection contributions to the acceleration. subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocen grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - 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),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh !< Zonal transport u*h*dy - !! [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh !< Meridional transport v*h*dx - !! [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: CAu !< Zonal acceleration due to Coriolis + type(ocean_grid_type), intent(in) :: G !< Ocen 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(in) :: uh !< Zonal transport u*h*dy + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vh !< Meridional transport v*h*dx + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: CAu !< Zonal acceleration due to Coriolis !! and momentum advection [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: CAv !< Meridional acceleration due to Coriolis + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: CAv !< Meridional acceleration due to Coriolis !! and momentum advection [L T-2 ~> m s-2]. - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv ! Local variables real, dimension(SZIB_(G),SZJB_(G)) :: & @@ -174,7 +174,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) min_fvq, & ! The minimum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. max_fuq, & ! The maximum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. min_fuq ! The minimum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. - real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & + 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 :: fv1, fv2, fu1, fu2 ! (f+rv)*v or (f+rv)*u [L T-2 ~> m s-2]. @@ -927,9 +927,9 @@ end subroutine CorAdCalc subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocen grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - 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),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + 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(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic !! energy gradient [L T-2 ~> m s-2] diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 1963a8a773..b4da255ddb 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -41,19 +41,19 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: PFu !< Zonal pressure force acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: PFv !< Meridional pressure force acceleration [L T-2 ~> m s-2] type(PressureForce_CS), pointer :: CS !< Pressure force control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), & optional, pointer :: p_atm !< The pressure at the ice-ocean or !! atmosphere-ocean interface [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer !! due to eta anomalies [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), & diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index f6be2d360d..4c42807e9f 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -74,36 +74,36 @@ module MOM_PressureForce_FV !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - 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_(G)), intent(in) :: h !< Layer thickness [H ~> kg/m2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control 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 ~> kg/m2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & S_t, & ! Top and bottom edge values for linear reconstructions S_b, & ! of salinity within each layer [ppt]. T_t, & ! Top and bottom edge values for linear reconstructions T_b ! of temperature within each layer [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dza, & ! The change in geopotential anomaly between the top and bottom ! of a layer [L2 T-2 ~> m2 s-2]. intp_dza ! The vertical integral in depth of the pressure anomaly less @@ -123,12 +123,12 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZIB_(G),SZJ_(G)) :: & intx_za ! The zonal integral of the geopotential anomaly along the ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G)) :: & inty_za ! The meridional integral of the geopotential anomaly along the ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). @@ -414,25 +414,25 @@ end subroutine PressureForce_FV_nonBouss !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - 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_(G)), intent(in) :: h !< Layer thickness [H ~> m] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control 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] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any !! tidal contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in depth units [Z ~> m]. + 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]. @@ -458,12 +458,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions ! of salinity and temperature within each layer. real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index b09805b347..f34dcd209e 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -61,34 +61,34 @@ module MOM_PressureForce_Mont !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) - 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_(G)), intent(in) :: h !< Layer thickness, [H ~> kg m-2]. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients - !! (equal to -dM/dx) [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients - !! (equal to -dM/dy) [L T-2 ~> m s-2]. - type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(out) :: pbce !< The baroclinic pressure anomaly in - !! each layer due to free surface height anomalies, - !! [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. + 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 ~> kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients + !! (equal to -dM/dx) [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients + !! (equal to -dM/dy) [L T-2 ~> m s-2]. + type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + !! each layer due to free surface height anomalies, + !! [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> kg m-1]. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. alpha_star, & ! Compression adjusted specific volume [R-1 ~> m3 kg-1]. dz_geo ! The change in geopotential across a layer [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. ! p may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but p will still be close to the pressure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter @@ -122,8 +122,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: I_gEarth ! The inverse of g_Earth [T2 Z L-2 ~> s2 m-1] ! real :: dalpha real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H). - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. - real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each + real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. + real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each ! interface [R-1 ~> m3 kg-1]. integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -358,32 +358,32 @@ end subroutine PressureForce_Mont_nonBouss !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) - 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_(G)), intent(in) :: h !< Layer thickness [H ~> m]. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients - !! (equal to -dM/dx) [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients - !! (equal to -dM/dy) [L T-2 ~> m s2]. - type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or + 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]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients + !! (equal to -dM/dx) [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients + !! (equal to -dM/dy) [L T-2 ~> m s2]. + type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or !! atmosphere-ocean [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies !! [L2 T-2 H-1 ~> m s-2]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> m]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> m]. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. rho_star ! In-situ density divided by the derivative with depth of the ! corrected e times (G_Earth/Rho0) [m2 Z-1 s-2 ~> m s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in m. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in m. ! e may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but e will still be close to the interface depth. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter @@ -606,18 +606,18 @@ end subroutine PressureForce_Mont_Bouss subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface height [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Rho0 !< The "Boussinesq" ocean density [R ~> kg m-3]. real, intent(in) :: GFS_scale !< Ratio between gravity applied to top !! interface and the gravitational acceleration of !! the planet [nondim]. Usually this ratio is 1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due !! to free surface height anomalies !! [L2 T-2 H-1 ~> m s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: rho_star !< The layer densities (maybe compressibility !! compensated), times g/rho_0 [L2 Z-1 T-2 ~> m s-2]. @@ -709,16 +709,16 @@ end subroutine Set_pbce_Bouss subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: p !< Interface pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: p !< Interface pressures [R L2 T-2 ~> Pa]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: GFS_scale !< Ratio between gravity applied to top !! interface and the gravitational acceleration of !! the planet [nondim]. Usually this ratio is 1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: pbce !< The baroclinic pressure anomaly in each + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: pbce !< The baroclinic pressure anomaly in each !! layer due to free surface height anomalies !! [L2 H-1 T-2 ~> m4 kg-1 s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: alpha_star !< The layer specific volumes + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: alpha_star !< The layer specific volumes !! (maybe compressibility compensated) [R-1 ~> m3 kg-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -730,8 +730,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [R ~> kg m-3]. - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. - real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each interface [R-1 ~> m3 kg-1]. + real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. + real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each interface [R-1 ~> m3 kg-1]. real :: dP_dH ! A factor that converts from thickness to pressure times other dimensional ! conversion factors [R L2 T-2 H-1 ~> Pa m2 kg-1]. real :: dp_neglect ! A thickness that is so small it is usually lost diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0cc1ab505c..bad76d7bce 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -411,19 +411,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_in !< The initial (3-D) zonal + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: U_in !< The initial (3-D) zonal !! velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_in !< The initial (3-D) meridional + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: V_in !< The initial (3-D) meridional !! velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height !! anomaly or column mass anomaly [H ~> m or kg m-2]. real, intent(in) :: dt !< The time increment to integrate over [T ~> s]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, !! [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, !! [L T-2 ~> m s-2]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: pbce !< 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, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_PF_in !< The 2-D eta field (either SSH anomaly or @@ -432,13 +432,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! eta_PF_start is provided [H ~> m or kg m-2]. !! Note: eta_in, pbce, and eta_PF_in must have up-to-date !! values in the first point of their halos. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_Cor !< The (3-D) zonal velocities used to + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: U_Cor !< The (3-D) zonal velocities used to !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_Cor !< The (3-D) meridional velocities used to + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: V_Cor !< The (3-D) meridional velocities used to !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due !! to the barotropic calculation [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer !! due to the barotropic calculation [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_out !< The final barotropic free surface !! height anomaly or column mass anomaly [H ~> m or kg m-2]. @@ -450,13 +450,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! [H L2 T-1 ~> m3 or kg s-1]. type(barotropic_CS), pointer :: CS !< The control structure returned by a !! previous call to barotropic_init. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: visc_rem_u !< Both the fraction of the momentum + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: visc_rem_u !< 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, in the zonal direction. Nondimensional !! between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass !! averaged over the barotropic integration [H ~> m or kg m-2]. type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers @@ -484,8 +484,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: ubt_Cor(SZIB_(G),SZJ_(G)) ! The barotropic velocities that had been real :: vbt_Cor(SZI_(G),SZJB_(G)) ! used to calculate the input Coriolis ! terms [L T-1 ~> m s-1]. - real :: wt_u(SZIB_(G),SZJ_(G),SZK_(G)) ! wt_u and wt_v are the - real :: wt_v(SZI_(G),SZJB_(G),SZK_(G)) ! normalized weights to + real :: wt_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! wt_u and wt_v are the + real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with ! sums less than one due to viscous losses. Nondimensional. real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -2647,7 +2647,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) type(barotropic_CS), pointer :: CS !< Barotropic control structure. real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta !< The barotropic free surface !! height anomaly or column mass anomaly [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: pbce !< The baroclinic pressure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: pbce !< 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(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe @@ -3183,13 +3183,13 @@ end subroutine destroy_BT_OBC subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(barotropic_CS), pointer :: CS !< The control structure returned by a previous !! call to barotropic_init. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: h_u !< The specified thicknesses at u-points [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: h_v !< The specified thicknesses at v-points [H ~> m or kg m-2]. logical, optional, intent(in) :: may_use_default !< An optional logical argument !! to indicate that the default velocity point @@ -3211,8 +3211,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) real :: wt_arith ! The nondimensional weight for the arithmetic mean thickness. ! The harmonic mean uses a weight of (1 - wt_arith). real :: Rh ! A ratio of summed thicknesses, nondim. - real :: e_u(SZIB_(G),SZK_(G)+1) ! The interface heights at u-velocity and - real :: e_v(SZI_(G),SZK_(G)+1) ! v-velocity points [H ~> m or kg m-2]. + real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity and + real :: e_v(SZI_(G),SZK_(GV)+1) ! v-velocity points [H ~> m or kg m-2]. real :: D_shallow_u(SZI_(G)) ! The shallower of the adjacent depths [H ~> m or kg m-2]. real :: D_shallow_v(SZIB_(G))! The shallower of the adjacent depths [H ~> m or kg m-2]. real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. @@ -4146,7 +4146,7 @@ end subroutine find_face_areas subroutine bt_mass_source(h, eta, set_cor, 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_(G)), 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]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be !! corrected [H ~> m or kg m-2]. logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective @@ -4206,11 +4206,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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) :: eta !< Free surface height or column mass anomaly diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 658a2d7ccf..17712491c4 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -111,14 +111,14 @@ end subroutine call_OBC_register !> Calls appropriate routine to update the open boundary conditions. subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, 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(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thicknesses [H ~> m or kg m-2] - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(update_OBC_CS), pointer :: CS !< Control structure for OBCs - type(time_type), intent(in) :: Time !< 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(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< layer thicknesses [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(time_type), intent(in) :: Time !< Model time ! Something here... with CS%file_OBC_CSp? ! if (CS%use_files) & diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index ae53a4086d..e77f90925f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -44,16 +44,16 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy 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. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] or other units. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] or other units. - 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]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: 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_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vh !< Volume flux through meridional faces = v*h*dx !! [H L2 T-1 ~> m3 s-1 or kg s-1]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -86,11 +86,11 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) 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. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] or [m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] or [m s-1].. - 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(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type, which is !! used to rescale u and v if present. @@ -179,33 +179,33 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p 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. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: CAu !< Zonal acceleration due to Coriolis !! and momentum advection terms [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: CAv !< Meridional acceleration due to Coriolis !! and momentum advection terms [L T-2 ~> m s-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: PFu !< Zonal acceleration due to pressure gradients !! (equal to -dM/dx) [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: PFv !< Meridional acceleration due to pressure gradients !! (equal to -dM/dy) [L T-2 ~> m s-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: diffu !< Zonal acceleration due to convergence of the !! along-isopycnal stress tensor [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: diffv !< Meridional acceleration due to convergence of !! the along-isopycnal stress tensor [L T-2 ~> m s-2]. 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)), & optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer !! due to free surface height anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: u_accel_bt !< The zonal acceleration from terms in the !! barotropic solver [L T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: v_accel_bt !< The meridional acceleration from terms in !! the barotropic solver [L T-2 ~> m s-2]. logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric @@ -235,11 +235,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, pointer, dimension(:,:,:), & intent(in) :: Temp !< Temperature [degC]. diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index cfb2b2e9fd..1ad37a82b8 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -43,18 +43,18 @@ subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, OBC, visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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]. @@ -68,20 +68,20 @@ subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, OBC, !! flux through meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), & optional, pointer :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + 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. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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), & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 1f9a2c3bbd..7b90297c64 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -78,17 +78,17 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, O type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(continuity_PPM_CS), pointer :: CS !< Module's control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: uh !< Zonal volume flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: vh !< Meridional volume flux, 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 @@ -100,24 +100,24 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, O !! [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), & optional, pointer :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_u !< The fraction of zonal 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. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_v !< The fraction of meridional 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. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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]. @@ -212,11 +212,11 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_u, u_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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, intent(in) :: dt !< Time increment [T ~> s]. @@ -225,7 +225,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(ocean_OBC_type), & optional, pointer :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_u !< The fraction of zonal 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 @@ -234,7 +234,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & 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]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: u_cor !< The zonal velocitiess (u with a barotropic correction) !! that give uhbt as the depth-integrated transport, m s-1. @@ -242,8 +242,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & !! effective open face areas as a function of barotropic flow. ! Local variables - real, dimension(SZIB_(G),SZK_(G)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. + 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(SZIB_(G)) :: & du, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. du_min_CFL, & ! Min/max limits on du correction @@ -252,7 +252,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & 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. logical, dimension(SZIB_(G)) :: do_I - real, dimension(SZIB_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZK_(GV)) :: & visc_rem ! A 2-D copy of visc_rem_u or an array of 1's. real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas [H L ~> m2 or kg m-1]. real :: FA_u ! A sum of zonal face areas [H m ~> m2 or kg m-1]. @@ -604,14 +604,14 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, marginal, visc_rem_u, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness used to + 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_(G)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_u !< Thickness at zonal faces [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Thickness at zonal faces [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. @@ -619,7 +619,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, !! of face areas to the cell areas when estimating the CFL number. logical, intent(in) :: marginal !< If true, report the !! marginal face thicknesses; otherwise report transport-averaged thicknesses. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_u !< 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 @@ -713,14 +713,14 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to + 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_(G)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + 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 !! the fraction of a time-step's worth of a barotropic acceleration that a layer !! experiences after viscosity is applied. @@ -749,11 +749,11 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & logical, optional, intent(in) :: full_precision !< !! A flag indicating how carefully to iterate. The !! default is .true. (more accurate). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: uh_3d !< + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: uh_3d !< !! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real, dimension(SZIB_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZK_(GV)) :: & uh_aux, & ! An auxiliary zonal volume flux [H L2 s-1 ~> m3 s-1 or kg s-1]. duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. real, dimension(SZIB_(G)) :: & @@ -878,12 +878,12 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to + 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_(G)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right 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. @@ -898,7 +898,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + 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 !! the fraction of a time-step's worth of a barotropic acceleration that a layer !! experiences after viscosity is applied. @@ -1039,20 +1039,20 @@ 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, vhbt, OBC, & visc_rem_v, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - 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),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Volume flux through meridional - !! faces = v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_PPM_CS), pointer :: CS !< This module's control structure.G - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary condition type + type(ocean_grid_type), intent(inout) :: 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 m2 s-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), pointer :: CS !< This module's control structure.G + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary condition type !! specifies whether, where, and what open boundary conditions are used. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & 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 @@ -1060,16 +1060,16 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & !! 0 (at the bottom) and 1 (far above the bottom). 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_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(out) :: v_cor !< The meridional velocitiess (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 !! the effective open face areas as a function of barotropic flow. ! Local variables - real, dimension(SZI_(G),SZK_(G)) :: & + 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_(G)) :: & + 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)) :: & dv, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. @@ -1081,7 +1081,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & logical, dimension(SZI_(G)) :: do_I real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas [H L ~> m2 or kg m-1]. real :: FA_v ! A sum of meridional face areas [H m ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & visc_rem ! A 2-D copy of visc_rem_v or an array of 1's. real :: I_vrm ! 1.0 / visc_rem_max, nondim. real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by @@ -1430,14 +1430,14 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, marginal, visc_rem_v, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - 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),SZK_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, + 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_(G)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: h_v !< Thickness at meridional faces, + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Thickness at meridional faces, !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. @@ -1446,7 +1446,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, !! of face areas to the cell areas when estimating the CFL number. logical, intent(in) :: marginal !< If true, report the marginal !! face thicknesses; otherwise report transport-averaged thicknesses. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), optional, intent(in) :: visc_rem_v !< Both the fraction + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), 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. @@ -1540,15 +1540,15 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + 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_(G)), & + 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_(G)),& + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),& intent(in) :: h_L !< Left thickness in the reconstruction [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_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem + 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 !! fraction of a time-step's worth of a barotropic acceleration that @@ -1574,12 +1574,12 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 intent(in) :: do_I_in !< A flag indicating which I values to work on. logical, optional, intent(in) :: full_precision !< A flag indicating how carefully to !! iterate. The default is .true. (more accurate). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(inout) :: vh_3d !< Volume flux through meridional !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & vh_aux, & ! An auxiliary meridional volume flux [H L2 s-1 ~> m3 s-1 or kg s-1]. dvhdv ! Partial derivative of vh with v [H m ~> m2 or kg m-1]. real, dimension(SZI_(G)) :: & @@ -1704,12 +1704,12 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - 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),SZK_(G)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, + 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_(G)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right 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. @@ -1724,7 +1724,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + 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 fraction of a time-step's worth of a barotropic !! acceleration that a layer experiences after viscosity is applied. diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 50b893dae7..dec97b6f98 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -245,11 +245,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & target, intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 @@ -260,16 +260,16 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !! time step [R L2 T-2 ~> Pa] real, dimension(:,:), pointer :: p_surf_end !< surf pressure at the end of this dynamic !! time step [R L2 T-2 ~> Pa] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uhtr !< accumulatated zonal volume/mass transport !! since last tracer advection [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vhtr !< accumulatated merid volume/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 time @@ -284,17 +284,17 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !! fields related to the surface wave conditions ! local variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + 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(SZIB_(G),SZJ_(G),SZK_(G)) :: u_bc_accel - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v_bc_accel + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! u_bc_accel and v_bc_accel are the summed 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_(G)), target :: uh_in - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target :: vh_in + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! uh_in and vh_in are the zonal or meridional mass transports that would be ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -307,8 +307,8 @@ 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_(G)) :: u_old_rad_OBC - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v_old_rad_OBC + 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 ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1]. @@ -1077,14 +1077,15 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)) , intent(inout) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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 @@ -1118,7 +1119,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !! from the continuity solver. ! local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. ! This include declares and sets the variable "version". # include "version_variable.h" diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a129e71465..193639becf 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -192,9 +192,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: 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]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical @@ -207,13 +207,13 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & !! pressure at the start of this dynamic step [R L2 T-2 ~> Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface !! pressure at the end of this dynamic step [R L2 T-2 ~> Pa]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uh !< The zonal volume or mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vh !< The meridional volume or mass !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< The accumulated zonal volume or mass + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< The accumulated zonal volume or mass !! transport since the last tracer advection [H L2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< The accumulated meridional volume or mass + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< The accumulated meridional volume or mass !! transport since the last tracer advection [H L2 ~> m3 or kg]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height or !! column mass [H ~> m or kg m-2]. @@ -227,9 +227,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & !! fields related to the surface wave conditions ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_av, hp ! Prediced or averaged layer thicknesses [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp ! Prediced or averaged layer thicknesses [H ~> m or kg m-2] + 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(:,:), pointer :: p_surf => NULL() real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. @@ -560,11 +560,11 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 307874eb14..429d150a63 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -194,11 +194,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u_in !< The input and output zonal + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_in !< The input and output zonal !! velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v_in !< The input and output meridional + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_in !< The input and output meridional !! velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_in !< The input and output layer thicknesses, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_in !< The input and output layer thicknesses, !! [H ~> m or kg m-2], depending on whether !! the Boussinesq approximation is made. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various @@ -216,14 +216,14 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to !! the surface pressure at the end of !! this dynamic step [R L2 T-2 ~> Pa]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uh !< The zonal volume or mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vh !< The meridional volume or mass !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< The accumulated zonal volume or + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< The accumulated zonal volume or !! mass transport since the last !! tracer advection [H L2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< The accumulated meridional volume + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< The accumulated meridional volume !! or mass transport since the last !! tracer advection [H L2 ~> m3 or kg]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height @@ -237,9 +237,9 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, !! fields related to the Mesoscale !! Eddy Kinetic Energy. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_av, hp - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp + 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(:,:), pointer :: p_surf => NULL() real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s] real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] @@ -508,9 +508,9 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: 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] type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dd7559aeac..35ea54a7ed 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -376,9 +376,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: T !< layer temperatures [degC] real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux !! (if Bouss) of water in/out of ocean over @@ -839,9 +839,9 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: T !< layer temperatures [degC] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux !! (if Bouss) of water in/out of ocean over @@ -893,12 +893,12 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt type(optics_type), pointer :: optics !< penetrating SW optics integer, intent(in) :: nsw !< The number of frequency bands of !! penetrating shortwave radiation - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< prognostic temp [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity [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) :: Temp !< prognostic temp [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [ppt] type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type integer, intent(in) :: j !< j-row to work on - real, dimension(SZI_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G)), intent(inout) :: netHeatMinusSW !< surf Heat flux !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)), intent(inout) :: netSalt !< surf salt flux @@ -917,7 +917,7 @@ 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 degC-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R ppt-1 ~> kg m-3 ppt-1] - real, dimension(SZI_(G),SZK_(G)+1) :: netPen ! The net penetrating shortwave radiation at each level + real, dimension(SZI_(G),SZK_(GV)+1) :: netPen ! The net penetrating shortwave radiation at each level ! [degC H ~> degC m or degC kg m-2] logical :: useRiverHeatContent @@ -988,11 +988,11 @@ subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< surface fluxes type(optics_type), pointer :: optics !< SW ocean optics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity [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) :: Temp !< temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [ppt] type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netHeatMinusSW !< surf temp flux !! [degC H ~> degC m or degC kg m-2] real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netSalt !< surf salt flux diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index d016b962d4..f44becf78f 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -32,11 +32,11 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) 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)), 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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] or [1/eta_to_m 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. @@ -47,9 +47,9 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables - real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] - real :: dz_geo(SZI_(G),SZJ_(G),SZK_(G)) ! The change in geopotential height - ! across a layer [L2 T-2 ~> m2 s-2]. + 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 :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] real :: I_gEarth ! The inverse of the gravitational acceleration times the @@ -149,7 +149,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) 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)), 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. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta !< free surface height relative to @@ -162,9 +162,9 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) 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. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dz_geo ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2]. 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 diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 68a4373314..e1f573f6ea 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -30,19 +30,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface heights [Z ~> m] or units + 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) 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, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction [nondim] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction [nondim] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute @@ -51,13 +51,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! 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_(G)) :: & + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & T, & ! The temperature [degC], with the values in ! in massless layers filled vertically by diffusion. S !, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. ! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. - real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & pres ! The pressure at an interface [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1]. @@ -388,27 +388,27 @@ 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) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Input temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Input salinity [ppt] - real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing - !! times a smoothing timescale [Z2 ~> m2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filled salinity [ppt] - integer, optional, intent(in) :: halo_here !< Number of halo points to work on, - !! 0 by default - logical, optional, intent(in) :: larger_h_denom !< Present and true, add a large - !! enough minimal thickness in the denominator of - !! the flux calculations so that the fluxes are - !! never so large as eliminate the transmission - !! of information across groups of massless 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),SZK_(GV)), intent(in) :: T_in !< Input temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [ppt] + real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing + !! times a smoothing timescale [Z2 ~> m2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [ppt] + integer, optional, intent(in) :: halo_here !< Number of halo points to work on, + !! 0 by default + logical, optional, intent(in) :: larger_h_denom !< Present and true, add a large + !! enough minimal thickness in the denominator of + !! the flux calculations so that the fluxes are + !! never so large as eliminate the transmission + !! of information across groups of massless layers. ! Local variables - real :: ent(SZI_(G),SZK_(G)+1) ! The diffusive entrainment (kappa*dt)/dz + 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_(G)) ! tridiagonal solver. + real :: c1(SZI_(G),SZK_(GV)) ! tridiagonal solver. 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 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3c6ada5fd1..1a4433f034 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2117,19 +2117,19 @@ end subroutine setup_OBC_tracer_reservoirs !> Apply radiation conditions to 3D u,v at open boundaries subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u_new !< On exit, new u values on open boundaries - !! On entry, the old time-level v but including - !! barotropic accelerations [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v_new !< On exit, new v values on open boundaries. - !! On entry, the old time-level v but including - !! barotropic accelerations [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt !< Appropriate timestep [T ~> s] + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_new !< On exit, new u values on open boundaries + !! On entry, the old time-level v but including + !! barotropic accelerations [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_new !< On exit, new v values on open boundaries. + !! On entry, the old time-level v but including + !! barotropic accelerations [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt !< Appropriate timestep [T ~> s] ! Local variables real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1] real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim] @@ -3232,9 +3232,9 @@ subroutine open_boundary_apply_normal_flow(OBC, G, GV, u, v) 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_(G)), intent(inout) :: u !< u field to update on open + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open !! boundaries [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open !! boundaries [L T-1 ~> m s-1] ! Local variables integer :: i, j, k, n @@ -3269,8 +3269,8 @@ subroutine open_boundary_zero_normal_flow(OBC, G, GV, u, v) 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_(G)), intent(inout) :: u !< u field to update on open boundaries - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open boundaries + 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 ! Local variables integer :: i, j, k, n type(OBC_segment_type), pointer :: segment => NULL() @@ -3301,8 +3301,8 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(OBC_segment_type), pointer :: segment !< OBC segment structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uvel !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vvel !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uvel !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vvel !< meridional velocity [L T-1 ~> m s-1] integer :: i,j,k if (.not. segment%on_pe) return @@ -3427,7 +3427,7 @@ subroutine set_tracer_data(OBC, tv, h, G, GV, PF, tracer_Reg) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness type(param_file_type), intent(in) :: PF !< Parameter file handle type(tracer_registry_type), pointer :: tracer_Reg !< Tracer registry ! Local variables @@ -3741,7 +3741,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< Model time ! Local variables integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed @@ -5062,17 +5062,17 @@ end subroutine open_boundary_register_restarts !> Update the OBC tracer reservoirs after the tracers have been updated. subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhr !< accumulated volume/mass flux through - !! the zonal face [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhr !< accumulated volume/mass flux through - !! the meridional face [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness after advection - !! [H ~> m or kg m-2] - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, intent(in) :: dt !< time increment [T ~> s] - type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through + !! the zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through + !! the meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection + !! [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, intent(in) :: dt !< time increment [T ~> s] + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry ! Local variables type(OBC_segment_type), pointer :: segment=>NULL() real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell [L ~> m] diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index aeee768272..50d5c65224 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -71,9 +71,9 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp 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(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: um !< The new zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various !! accelerations in the momentum equations. @@ -85,9 +85,9 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp 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 integrated over a time !! step divided by the Boussinesq density [m2 s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z s-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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]. ! Local variables @@ -95,13 +95,13 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp real :: Angstrom real :: truncvel, du real :: dt ! The time step [s] - real :: Inorm(SZK_(G)) - real :: e(SZK_(G)+1) + real :: Inorm(SZK_(GV)) + real :: e(SZK_(GV)+1) real :: h_scale, uh_scale integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz - logical :: do_k(SZK_(G)+1) + logical :: do_k(SZK_(GV)+1) logical :: prev_avail integer :: file @@ -404,9 +404,9 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp 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),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vm !< The new meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various !! accelerations in the momentum equations. @@ -418,9 +418,9 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp 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 integrated over a time !! step divided by the Boussinesq density [m2 s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z s-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + 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]. ! Local variables @@ -428,13 +428,13 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp real :: Angstrom real :: truncvel, dv real :: dt ! The time step [s] - real :: Inorm(SZK_(G)) - real :: e(SZK_(G)+1) + real :: Inorm(SZK_(GV)) + real :: e(SZK_(GV)+1) real :: h_scale, uh_scale integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz - logical :: do_k(SZK_(G)+1) + logical :: do_k(SZK_(GV)+1) logical :: prev_avail integer :: file diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index f1c3a0c777..e286d7bceb 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -197,16 +197,16 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: uh !< Transport through zonal faces = u*h*dy, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vh !< Transport through meridional faces = v*h*dx, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various @@ -233,8 +233,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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, nkmb - real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. - real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) ! A 3-d temporary work array. + real :: Rcv(SZI_(G),SZJ_(G),SZK_(GV)) ! Coordinate variable potential density [R ~> kg m-3]. + real :: work_3d(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary work array. real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] @@ -252,7 +252,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & integer :: k_list - real, dimension(SZK_(G)) :: temp_layer_ave, salt_layer_ave + real, dimension(SZK_(GV)) :: temp_layer_ave, salt_layer_ave real :: thetaoga, soga, masso, tosga, sosga is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -833,7 +833,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, 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. 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. @@ -949,16 +949,16 @@ end subroutine calculate_vertical_integrals subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: uh !< Transport through zonal faces=u*h*dy, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vh !< Transport through merid faces=v*h*dx, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. type(accel_diag_ptrs), intent(in) :: ADp !< Structure pointing to accelerations in momentum equation. @@ -1408,11 +1408,11 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr !< Accumulated zonal thickness fluxes + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhtr !< Accumulated zonal thickness fluxes !! used to advect tracers [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhtr !< Accumulated meridional thickness fluxes + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhtr !< Accumulated meridional thickness fluxes !! used to advect tracers [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< The updated layer thicknesses [H ~> m or kg m-2] type(transport_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(diag_grid_storage), intent(inout) :: diag_pre_dyn !< Stored grids from before dynamics @@ -1423,9 +1423,9 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy ! 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_(G)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tend ! Change in layer thickness due to dynamics + 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 s-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] real :: H_to_RZ_dt ! A conversion factor from accumulated transports to fluxes diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index ab0e0e1af1..b79bc77e76 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -299,11 +299,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(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. @@ -318,22 +318,22 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ optional, pointer :: OBC !< Open boundaries control structure. type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step ! Local variables - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces [Z ~> m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The height of interfaces [Z ~> m]. real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [L2 ~> m2]. - real :: KE(SZK_(G)) ! The total kinetic energy of a layer [J]. - real :: PE(SZK_(G)+1)! The available potential energy of an interface [J]. + real :: KE(SZK_(GV)) ! The total kinetic energy of a layer [J]. + real :: PE(SZK_(GV)+1)! The available potential energy of an interface [J]. real :: KE_tot ! The total kinetic energy [J]. real :: PE_tot ! The total available potential energy [J]. - real :: Z_0APE(SZK_(G)+1) ! The uniform depth which overlies the same + 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_(G)+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. 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 ! the total mass of the ocean [m2 s-2]. - real :: vol_lay(SZK_(G)) ! The volume of fluid in a layer [Z L2 ~> m3]. + real :: vol_lay(SZK_(GV)) ! The volume of fluid in a layer [Z L2 ~> m3]. real :: volbelow ! The volume of all layers beneath an interface [Z L2 ~> m3]. - real :: mass_lay(SZK_(G)) ! The mass of fluid in a layer [kg]. + real :: mass_lay(SZK_(GV)) ! The mass of fluid in a layer [kg]. real :: mass_tot ! The total mass of the ocean [kg]. real :: vol_tot ! The total ocean volume [m3]. real :: mass_chg ! The change in total ocean mass of fresh water since @@ -383,9 +383,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ real :: CFL_lin ! A simpler definition of the CFL number [nondim]. real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. real :: Irho0 ! The inverse of the reference density [m3 kg-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & tmp1 ! A temporary array - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & PE_pt ! The potential energy at each point [J]. real, dimension(SZI_(G),SZJ_(G)) :: & Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 86482b9a03..8b32e48788 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -59,7 +59,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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_(G)), & + 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, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] @@ -74,7 +74,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. @@ -84,7 +84,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !! wave speeds [nondim] ! Local variables - real, dimension(SZK_(G)+1) :: & + real, dimension(SZK_(GV)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] @@ -93,15 +93,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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]. - real, dimension(SZK_(G)) :: & + 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_(G),SZI_(G)) :: & + 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 [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] - real, dimension(SZK_(G)) :: & + real, dimension(SZK_(GV)) :: & Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] @@ -149,7 +149,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction, l_mono_N2_depth - real :: mode_struct(SZK_(G)), ms_min, ms_max, ms_sq + real :: mode_struct(SZK_(GV)), ms_min, ms_max, ms_sq is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -642,7 +642,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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_(G)), 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] @@ -657,7 +657,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee !! wave speeds [nondim] ! Local variables - real, dimension(SZK_(G)+1) :: & + real, dimension(SZK_(GV)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] @@ -666,12 +666,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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]. - real, dimension(SZK_(G),SZI_(G)) :: & + 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 [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] - real, dimension(SZK_(G)) :: & + 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 istabilities are removed [Z ~> m] diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index c3a5b6ef46..e0733ad09c 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -92,7 +92,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(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 @@ -106,22 +106,22 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. ! Local variables - real, dimension(SZK_(G)+1) :: & + real, dimension(SZK_(GV)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. - real, dimension(SZK_(G)) :: & + 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 [s2 m-2]. - real, dimension(SZK_(G),SZI_(G)) :: & + 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 [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] - real, dimension(SZK_(G)) :: & + real, dimension(SZK_(GV)) :: & Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] @@ -154,13 +154,13 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real :: Kmag2 ! magnitude of horizontal wave number squared logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. - real, dimension(SZK_(G)+1) :: w_strct, u_strct, W_profile, Uavg_profile, z_int, N2 + real, dimension(SZK_(GV)+1) :: w_strct, u_strct, W_profile, Uavg_profile, z_int, N2 ! local representations of variables in CS; note, ! not all rows will be filled if layers get merged! - real, dimension(SZK_(G)+1) :: w_strct2, u_strct2 + real, dimension(SZK_(GV)+1) :: w_strct2, u_strct2 ! squared values - real, dimension(SZK_(G)) :: dz ! thicknesses of merged layers (same as Hc I hope) - ! real, dimension(SZK_(G)+1) :: dWdz_profile ! profile of dW/dz + real, dimension(SZK_(GV)) :: dz ! thicknesses of merged layers (same as Hc I hope) + ! real, dimension(SZK_(GV)+1) :: dWdz_profile ! profile of dW/dz real :: w2avg ! average of squared vertical velocity structure funtion real :: int_dwdz2 real :: int_w2 @@ -169,13 +169,13 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real :: PE_term ! terms in vertically averaged energy equation real :: W0 ! A vertical velocity magnitude [Z T-1 ~> m s-1] real :: gp_unscaled ! A version of gprime rescaled to [m s-2]. - real, dimension(SZK_(G)-1) :: lam_z ! product of eigen value and gprime(k); one value for each + real, dimension(SZK_(GV)-1) :: lam_z ! product of eigen value and gprime(k); one value for each ! interface (excluding surface and bottom) - real, dimension(SZK_(G)-1) :: a_diag, b_diag, c_diag + real, dimension(SZK_(GV)-1) :: a_diag, b_diag, c_diag ! diagonals of tridiagonal matrix; one value for each ! interface (excluding surface and bottom) - real, dimension(SZK_(G)-1) :: e_guess ! guess at eigen vector with unit amplitde (for TDMA) - real, dimension(SZK_(G)-1) :: e_itt ! improved guess at eigen vector (from TDMA) + real, dimension(SZK_(GV)-1) :: e_guess ! guess at eigen vector with unit amplitde (for TDMA) + real, dimension(SZK_(GV)-1) :: e_itt ! improved guess at eigen vector (from TDMA) real :: Pi integer :: kc integer :: i, j, k, k2, itt, is, ie, js, je, nz, nzm, row, ig, jg, ig_stop, jg_stop diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 38788411b8..3733dda6a4 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -117,13 +117,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u !< The zonal velocity that is being !! initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: v !< The meridional velocity that is being !! initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables @@ -632,7 +632,7 @@ subroutine initialize_thickness_from_file(h, G, GV, US, param_file, file_has_thi !! only read parameters without changing h. ! Local variables - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! Interface heights, in depth units. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units. integer :: inconsistent = 0 logical :: correct_thickness logical :: just_read ! If true, just read parameters but set nothing. @@ -710,11 +710,11 @@ end subroutine initialize_thickness_from_file !! @remark{There is a (hard-wired) "tolerance" parameter such that the !! criteria for adjustment must equal or exceed 10cm.} subroutine adjustEtaToFitBathymetry(G, GV, US, eta, 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + 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)+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] ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] @@ -794,9 +794,9 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) !! only read parameters without changing h. ! Local variables character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. - real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units, usually + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units, usually ! negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units. logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz @@ -850,9 +850,9 @@ subroutine initialize_thickness_list(h, G, GV, US, param_file, just_read_params) !! only read parameters without changing h. ! Local variables character(len=40) :: mdl = "initialize_thickness_list" ! This subroutine's name. - real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], ! usually negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, eta_file, inputdir ! Strings for file/path @@ -923,7 +923,7 @@ 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_(G)), & + 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 @@ -998,7 +998,7 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure 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(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] 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 @@ -1007,7 +1007,7 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & eta_sfc ! The free surface height that the model should use [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & + 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 @@ -1085,15 +1085,15 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ALE_CS), pointer :: ALE_CSp !< ALE control structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables character(len=200) :: mdl = "trim_for_ice" real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_t, S_b ! Top and bottom edge values for reconstructions - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity [ppt] and temperature [degC] within each layer. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S_t, S_b ! Top and bottom edge values for reconstructions + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! of salinity [ppt] and temperature [degC] within each layer. 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]. @@ -1271,9 +1271,9 @@ end subroutine cut_off_column_top subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: v !< The meridional velocity that is being initialized [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 @@ -1313,9 +1313,9 @@ end subroutine initialize_velocity_from_file subroutine initialize_velocity_zero(u, v, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: v !< The meridional velocity that is being initialized [L T-1 ~> m s-1] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. @@ -1348,9 +1348,9 @@ end subroutine initialize_velocity_zero subroutine initialize_velocity_uniform(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: v !< The meridional velocity that is being initialized [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 @@ -1390,15 +1390,15 @@ end subroutine initialize_velocity_uniform subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(out) :: v !< The meridional velocity that is being initialized [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, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing u or v. ! 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] @@ -1452,15 +1452,15 @@ end subroutine initialize_velocity_circular !> Initializes temperature and salinity from file subroutine initialize_temp_salt_from_file(T, S, G, GV, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] + type(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) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T or S. ! Local variables logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, salt_filename ! Full paths to input files @@ -1509,17 +1509,17 @@ end subroutine initialize_temp_salt_from_file !> Initializes temperature and salinity from a 1D profile subroutine initialize_temp_salt_from_profile(T, S, G, GV, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] + type(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) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T or S. ! Local variables - real, dimension(SZK_(G)) :: T0, S0 + real, dimension(SZK_(GV)) :: T0, S0 integer :: i, j, k logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, ts_file, inputdir ! Strings for file/path @@ -1557,9 +1557,9 @@ end subroutine initialize_temp_salt_from_profile subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is !! being initialized [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being !! initialized [ppt]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -1568,16 +1568,16 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P real, intent(in) :: P_Ref !< The coordinate-density reference pressure !! [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T or S. ! Local variables - real :: T0(SZK_(G)) ! Layer potential temperatures [degC] - real :: S0(SZK_(G)) ! Layer salinities [degC] + real :: T0(SZK_(GV)) ! Layer potential temperatures [degC] + real :: S0(SZK_(GV)) ! Layer salinities [degC] real :: T_Ref ! Reference Temperature [degC] real :: S_Ref ! Reference Salinity [ppt] - real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. @@ -1649,18 +1649,17 @@ end subroutine initialize_temp_salt_fit !! \remark Note that the linear distribution is set up with respect to the layer !! number, not the physical position). subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] - type(param_file_type), intent(in) :: param_file !< A structure to parse for - !! run-time parameters - logical, optional, intent(in) :: just_read_params !< If present and true, - !! this call will only read - !! parameters without - !! changing 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, optional, intent(in) :: just_read_params !< If present and true, + !! this call will only read parameters + !! without changing T or S. integer :: k real :: delta_S, delta_T @@ -1734,7 +1733,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m]. real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. - real, dimension (SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: & tmp, tmp2 ! A temporary array for tracers. real, dimension (SZI_(G),SZJ_(G)) :: & tmp_2d ! A temporary array for tracers. @@ -1862,9 +1861,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) - call set_up_sponge_field(tmp, tv%T, G, nz, Layer_CSp) + call set_up_sponge_field(tmp, tv%T, G, GV, nz, Layer_CSp) call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) - call set_up_sponge_field(tmp, tv%S, G, nz, Layer_CSp) + call set_up_sponge_field(tmp, tv%S, G, GV, nz, Layer_CSp) endif endif @@ -1895,9 +1894,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L if (use_temperature) then allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) call MOM_read_data(filename, potemp_var, tmp_tr(:,:,:), G%Domain) - call set_up_ALE_sponge_field(tmp_tr, G, tv%T, ALE_CSp) + call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%T, ALE_CSp) call MOM_read_data(filename, salin_var, tmp_tr(:,:,:), G%Domain) - call set_up_ALE_sponge_field(tmp_tr, G, tv%S, ALE_CSp) + call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%S, ALE_CSp) deallocate(tmp_tr) endif else @@ -1976,16 +1975,16 @@ end subroutine set_velocity_depth_min !! a latitude-longitude grid. subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_params) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: h !< Layer thicknesses being initialized [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables including temperature and salinity - 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) :: PF !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T or S. ! Local variables character(len=200) :: filename !< The name of an input file containing temperature @@ -2042,7 +2041,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. integer, dimension(SZI_(G),SZJ_(G)) :: nlevs real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. @@ -2464,10 +2463,10 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, GV, US, nlevs, n real, dimension(SZI_(G),SZJ_(G),nk_data), & intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] real, dimension(nk_data), intent(in) :: zin !< Input data levels [Z ~> m]. - real, dimension(SZK_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + real, dimension(SZK_(GV)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth !< ocean depth [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: zi !< The returned interface heights [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, dimension(SZI_(G),SZJ_(G)), & @@ -2480,7 +2479,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, GV, US, nlevs, n ! Local variables real, dimension(nk_data) :: rho_ ! A column of densities [R ~> kg m-3] - real, dimension(SZK_(G)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. + 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 diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index c349ab30b1..48b67bf295 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -39,7 +39,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ 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_(G)), & + 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 type(param_file_type), intent(in) :: PF !< parameter file diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index acc316cce4..2572e15a04 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -308,7 +308,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + 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(ODA_CS), pointer :: CS !< ocean DA control structure @@ -525,11 +525,12 @@ end subroutine save_obs_diff !> Apply increments to tracers -subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) +subroutine apply_oda_tracer_increments(dt, G, GV, tv, h, CS) real, intent(in) :: dt !< The tracer timestep [s] type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(ODA_CS), intent(inout) :: CS !< the data assimilation structure diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index ae84858234..562694a1e1 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -113,14 +113,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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]. real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. type(MEKE_CS), pointer :: CS !< MEKE control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Accumlated zonal mass flux [H L2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Accumlated meridional mass flux [H L2 ~> m3 or kg] + 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] ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 65d2c34d06..ffe97dffe8 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -216,16 +216,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, CS, OBC, BT, TD, ADp) 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_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + 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]. type(MEKE_type), pointer :: MEKE !< Pointer to a structure containing fields @@ -301,7 +301,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_vel_mag_bt_q, & ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] - real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] Kh_q, & ! Laplacian viscosity at corner points [L2 T-1 ~> m2 s-1] vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] @@ -309,11 +309,11 @@ 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] max_diss_rate_q ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+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] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+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] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + 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] max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] @@ -321,7 +321,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] sh_xx_h ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & 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] diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 37116fcae6..37fcd15f6a 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -154,7 +154,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 !< Pointer to thermodynamic variables !! (needed for wave structure). diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d0f81853e3..9fdd701da1 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -188,12 +188,12 @@ end subroutine calc_depth_function !> Calculates and stores the non-dimensional resolution functions subroutine calc_resoln_function(h, tv, G, GV, US, CS) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + 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] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some @@ -434,19 +434,19 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: dt !< Time increment [T ~> s] - type(VarMix_CS), pointer :: CS !< Variable mixing coefficients - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(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), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(G)+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_(G)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [T-2 ~> s-2] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") @@ -479,18 +479,18 @@ end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) - 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_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: slope_x !< Zonal isoneutral slope - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency - !! at u-points [T-2 ~> s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: slope_y !< Meridional isoneutral slope - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency - !! at v-points [T-2 ~> s-2] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), pointer :: CS !< Variable mixing coefficients - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + 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) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency + !! at u-points [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) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency + !! at v-points [T-2 ~> s-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [nondim] @@ -644,15 +644,15 @@ end subroutine calc_Visbeck_coeffs !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), pointer :: CS !< Variable mixing coefficients - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position [Z ~> m] - logical, intent(in) :: calculate_slopes !< If true, calculate slopes internally - !! otherwise use slopes stored in CS - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + 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(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), pointer :: CS !< Variable mixing coefficients + 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 + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! 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) @@ -667,8 +667,8 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop integer :: is, ie, js, je, nz integer :: i, j, k, kb_max integer :: l_seg - real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) - real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) + real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(GV)) + real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(GV)) logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & @@ -809,7 +809,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + 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 !! (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 1d28d58b55..2834f87121 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -88,21 +88,21 @@ module MOM_mixed_layer_restrat !! 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) - 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_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux - !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), 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 :: MLD !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] - type(VarMix_CS), pointer :: VarMix !< Container for derived fields - type(mixedlayer_restrat_CS), pointer :: 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 :: MLD !< Mixed layer depth provided by the + !! PBL scheme [Z ~> m] + type(VarMix_CS), pointer :: VarMix !< Container for derived fields + type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure if (.not. associated(CS)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "Module must be initialized before it is used.") @@ -118,25 +118,25 @@ 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) ! Arguments - 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_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux - !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), 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 :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] (not H) - type(VarMix_CS), pointer :: VarMix !< Container for derived fields - type(mixedlayer_restrat_CS), pointer :: 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 :: MLD_in !< Mixed layer depth provided by the + !! PBL scheme [Z ~> m] (not H) + type(VarMix_CS), pointer :: VarMix !< Container for derived fields + type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + 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, 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]. real, dimension(SZI_(G),SZJ_(G)) :: & @@ -159,11 +159,11 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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_(G)) ! A non-dimensional value relating the overall flux + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a ! layer. The vertical sum of a() through the pieces of ! the mixed layer must be 0. - real :: b(SZK_(G)) ! As for a(k) but for the slow-filtered MLD + real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD 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 @@ -560,22 +560,22 @@ end subroutine mixedlayer_restrat_general !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux - !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), 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] - type(mixedlayer_restrat_CS), pointer :: CS !< Module 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(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] + type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + 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, 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]. real, dimension(SZI_(G),SZJ_(G)) :: & @@ -596,7 +596,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) 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] real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] - real :: a(SZK_(G)) ! A non-dimensional value relating the overall flux + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a ! layer. The vertical sum of a() through the pieces of ! the mixed layer must be 0. diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index c83df84d4b..0751177a5d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -106,39 +106,39 @@ module MOM_thickness_diffuse !! 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 - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux - !! [L2 H ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux - !! [L2 H ~> m3 or kg] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt !< Time increment [T ~> s] - type(MEKE_type), pointer :: MEKE !< MEKE control structure - type(VarMix_CS), pointer :: VarMix !< Variable mixing coefficients - type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation - type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion + 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(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 + !! [L2 H ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [L2 H ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(MEKE_type), pointer :: MEKE !< MEKE control structure + type(VarMix_CS), pointer :: VarMix !< Variable mixing coefficients + type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation + type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion ! Local variables - real :: e(SZI_(G), SZJ_(G), SZK_(G)+1) ! heights of interfaces, relative to mean + real :: e(SZI_(G), SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. - real :: uhD(SZIB_(G), SZJ_(G), SZK_(G)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] - real :: vhD(SZI_(G), SZJB_(G), SZK_(G)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: uhD(SZIB_(G), SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + 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_(G)+1) :: & + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: & KH_u, & ! interface 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_(G)+1) :: & + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: & KH_v, & ! interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. - real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] real, dimension(SZIB_(G), SZJ_(G)) :: & @@ -552,36 +552,36 @@ end subroutine thickness_diffuse !! Called by thickness_diffuse(). subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & CS, int_slope_u, int_slope_v, slope_x, slope_y) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - 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 or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces + 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)+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 !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces !! at v points [L2 T-1 ~> m2 s-1] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uhD !< Zonal mass fluxes + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes !! [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vhD !< Meridional mass fluxes + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes !! [H L2 T-1 ~> m3 s-1 or kg s-1] - real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] - real, intent(in) :: dt !< Time increment [T ~> s] - type(MEKE_type), pointer :: MEKE !< MEKE control structure - type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of + real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(MEKE_type), pointer :: MEKE !< MEKE control structure + type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of !! density gradients [nondim]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: int_slope_v !< Ratio that determine how much of + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of !! density gradients [nondim]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & + 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. S, & ! The filled salinity [ppt], with the values in @@ -590,15 +590,15 @@ 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 s-2], ! used for calculating PE release - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: & + 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 ! thickness in m times Brunt-Vaisala freqeuncy at u-points [L2 Z-1 T-2 ~> m s-2], ! used for calculating PE release - real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & + 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]. real, dimension(SZIB_(G)) :: & @@ -630,12 +630,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the ! interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. - real :: drdi_u(SZIB_(G), SZK_(G)) ! Copy of drdi at u-points [R ~> kg m-3]. - real :: drdj_v(SZI_(G), SZK_(G)) ! Copy of drdj at v-points [R ~> kg m-3]. - real :: drdkDe_u(SZIB_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at u-points - ! [Z R ~> kg m-2]. - real :: drdkDe_v(SZI_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at v-points - ! [Z R ~> kg m-2]. + 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]. + real :: drdkDe_u(SZIB_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at u-points + ! [Z R ~> kg m-2]. + real :: drdkDe_v(SZI_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at v-points + ! [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]. @@ -643,16 +643,16 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. - real :: c2_h_u(SZIB_(G), SZK_(G)+1) ! Wave speed squared divided by h at u-points [L2 Z-1 T-2 ~> m s-2]. - real :: c2_h_v(SZI_(G), SZK_(G)+1) ! Wave speed squared divided by h at v-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_u(SZIB_(G), SZK_(G)+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_(G)+1) ! Thickness in m times N2 at interfaces above v-points [L2 Z-1 T-2 ~> m s-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 :: 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_(G)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_v(SZI_(G), SZK_(G)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. - real :: slope2_Ratio_u(SZIB_(G), SZK_(G)+1) ! The ratio of the slope squared to slope_max squared. - real :: slope2_Ratio_v(SZI_(G), SZK_(G)+1) ! The ratio of the slope squared to slope_max squared. + 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]. + real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. + real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. 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 @@ -680,10 +680,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: mn_T2 ! mean of T**2 in local stencil [degC] 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, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tsgs2 ! Sub-grid temperature variance [degC2] - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics - real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics logical :: present_int_slope_u, present_int_slope_v logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of @@ -1465,38 +1465,38 @@ end subroutine streamfn_solver !> Modifies thickness diffusivities to untangle layer structures subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - 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 or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+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_(G)+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 - !! 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), pointer :: CS !< Control structure for thickness diffusion - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of - !! the isopycnal slopes are taken directly from - !! the interface slopes without consideration - !! of density gradients. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+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. + 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)+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 + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion + 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. + 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. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(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_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & Kh_lay_u ! The tentative interface height diffusivity for each layer at ! u points [L2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & Kh_lay_v ! The tentative interface height diffusivity for each layer at ! v points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & @@ -1535,11 +1535,11 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. real :: wt1, wt2 ! Nondimensional weights. ! Variables used only in testing code. - ! real, dimension(SZK_(G)) :: uh_here - ! real, dimension(SZK_(G)+1) :: Sfn + ! real, dimension(SZK_(GV)) :: uh_here + ! real, dimension(SZK_(GV)+1) :: Sfn real :: dKh ! An increment in the diffusivity [L2 T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZK_(G)+1) :: & + real, dimension(SZIB_(G),SZK_(GV)+1) :: & Kh_bg, & ! The background (floor) value of Kh [L2 T-1 ~> m2 s-1]. Kh, & ! The tentative value of Kh [L2 T-1 ~> m2 s-1]. Kh_detangle, & ! The detangling diffusivity that could be used [L2 T-1 ~> m2 s-1]. @@ -2091,9 +2091,9 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) type(thickness_diffuse_CS), pointer :: 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_(G)+1), intent(inout) :: KH_u_GME !< interface height + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< interface height !! diffusivities at u-faces [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: KH_v_GME !< interface height + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< interface height !! diffusivities at v-faces [L2 T-1 ~> m2 s-1] ! Local variables integer :: i,j,k diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 09cd050a4a..b794d5aa89 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -556,13 +556,15 @@ end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable !! whose address is given by f_ptr. -subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). +subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & - intent(in) :: sp_val !< Field to be used in the sponge, it has arbitrary number of layers. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - target, intent(in) :: f_ptr !< Pointer to the field to be damped + intent(in) :: sp_val !< Field to be used in the sponge, it can have an + !! arbitrary number of layers. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -658,15 +660,16 @@ end subroutine set_up_ALE_sponge_field_varying !> This subroutine stores the reference profile at u and v points for the variable !! whose address is given by u_ptr and v_ptr. -subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). +subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, CS) + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), & - intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers. + intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers. real, dimension(SZI_(G),SZJB_(G),CS%nz_data), & - intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped + intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target, intent(in) :: u_ptr !< u pointer to the field to be damped + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target, intent(in) :: v_ptr !< v pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -696,17 +699,18 @@ end subroutine set_up_ALE_sponge_vel_field_fixed !> This subroutine stores the reference profile at uand v points for the variable !! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename_v, fieldname_v, & - Time, G, US, CS, u_ptr, v_ptr) + Time, G, GV, US, CS, u_ptr, v_ptr) character(len=*), intent(in) :: filename_u !< File name for u field character(len=*), intent(in) :: fieldname_u !< Name of u variable in file character(len=*), intent(in) :: filename_v !< File name for v field character(len=*), intent(in) :: fieldname_v !< Name of v variable in file type(time_type), intent(in) :: Time !< Model time type(ocean_grid_type), intent(inout) :: G !< Ocean grid (in) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). ! Local variables real, allocatable, dimension(:,:,:) :: u_val !< U field to be used in the sponge. real, allocatable, dimension(:,:,:) :: mask_u !< U field mask for the sponge data. @@ -795,8 +799,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid - real, dimension(SZK_(G)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(G)) :: h_col ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid + 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, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. @@ -1080,7 +1084,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) call rotate_array(sp_val_in, turns, sp_val) ! NOTE: This points sp_val with the unrotated field. See note below. - call set_up_ALE_sponge_field(sp_val, G, sp_ptr, sponge) + call set_up_ALE_sponge_field(sp_val, G, GV, sp_ptr, sponge) deallocate(sp_val_in) else diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index bfd0f77b38..92b8c9a2f0 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -548,7 +548,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) CS%id_La_SL = register_diag_field('ocean_model', 'KPP_La_SL', diag%axesT1, Time, & 'Surface-layer Langmuir number computed in [CVMix] KPP','nondim') - allocate( CS%N( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + allocate( CS%N( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) CS%N(:,:,:) = 0. allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) CS%OBLdepth(:,:) = 0. @@ -556,28 +556,28 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) CS%kOBL(:,:) = 0. allocate( CS%La_SL( SZI_(G), SZJ_(G) ) ) CS%La_SL(:,:) = 0. - allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(G) ) ) + allocate( CS%Vt2( SZI_(G), SZJ_(G),SZK_(GV) ) ) CS%Vt2(:,:,:) = 0. if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) ) ; CS%OBLdepthprev(:,:) = 0.0 - if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) + if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G),SZK_(GV) ) ) if (CS%id_BulkDrho > 0) CS%dRho(:,:,:) = 0. - if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(G) ) ) + if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G),SZK_(GV) ) ) if (CS%id_BulkUz2 > 0) CS%Uz2(:,:,:) = 0. - if (CS%id_BulkRi > 0) allocate( CS%BulkRi( SZI_(G), SZJ_(G), SZK_(G) ) ) + if (CS%id_BulkRi > 0) allocate( CS%BulkRi( SZI_(G), SZJ_(G),SZK_(GV) ) ) if (CS%id_BulkRi > 0) CS%BulkRi(:,:,:) = 0. - if (CS%id_Sigma > 0) allocate( CS%sigma( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_Sigma > 0) allocate( CS%sigma( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_Sigma > 0) CS%sigma(:,:,:) = 0. - if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(G) ) ) + if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G),SZK_(GV) ) ) if (CS%id_Ws > 0) CS%Ws(:,:,:) = 0. - if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_N2 > 0) CS%N2(:,:,:) = 0. - if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_Kt_KPP > 0) CS%Kt_KPP(:,:,:) = 0. - if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_Ks_KPP > 0) CS%Ks_KPP(:,:,:) = 0. - if (CS%id_Kv_KPP > 0) allocate( CS%Kv_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_Kv_KPP > 0) allocate( CS%Kv_KPP( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_Kv_KPP > 0) CS%Kv_KPP(:,:,:) = 0. if (CS%id_Tsurf > 0) allocate( CS%Tsurf( SZI_(G), SZJ_(G)) ) if (CS%id_Tsurf > 0) CS%Tsurf(:,:) = 0. @@ -587,9 +587,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_Usurf > 0) CS%Usurf(:,:) = 0. if (CS%id_Vsurf > 0) allocate( CS%Vsurf( SZI_(G), SZJB_(G)) ) if (CS%id_Vsurf > 0) CS%Vsurf(:,:) = 0. - if (CS%id_EnhVt2 > 0) allocate( CS%EnhVt2( SZI_(G), SZJ_(G), SZK_(G)) ) + if (CS%id_EnhVt2 > 0) allocate( CS%EnhVt2( SZI_(G), SZJ_(G),SZK_(GV)) ) if (CS%id_EnhVt2 > 0) CS%EnhVt2(:,:,:) = 0. - if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) @@ -603,25 +603,25 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & nonLocalTransScalar, waves) ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - 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 - type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] - 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_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP + type(KPP_CS), pointer :: CS !< Control structure + 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)), 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 !! (out) Vertical diffusivity including KPP !! [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP + 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP + 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_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport [m 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] + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS ! Local variables integer :: i, j, k ! Loop indices @@ -907,14 +907,14 @@ 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_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity [ppt] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] + 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) :: Temp !< potential/cons temp [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] 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_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] + 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), optional, pointer :: Waves !< Wave CS ! Local variables @@ -1286,7 +1286,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + 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 @@ -1391,16 +1391,16 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & type(KPP_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] real, intent(in) :: dt !< Time-step [s] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< temperature real, intent(in) :: C_p !< Seawater specific heat capacity [J kg-1 degC-1] integer :: i, j, k - real, dimension( SZI_(G), SZJ_(G), SZK_(G) ) :: dtracer + real, dimension( SZI_(G), SZJ_(G),SZK_(GV) ) :: dtracer dtracer(:,:,:) = 0.0 @@ -1453,15 +1453,15 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, type(KPP_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] real, intent(in) :: dt !< Time-step [s] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< Scalar (scalar units [conc]) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Scalar (scalar units [conc]) integer :: i, j, k - real, dimension( SZI_(G), SZJ_(G), SZK_(G) ) :: dtracer + real, dimension( SZI_(G), SZJ_(G),SZK_(GV) ) :: dtracer dtracer(:,:,:) = 0.0 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 7c5547c911..f65a7d150e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -149,13 +149,13 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) type(CVMix_conv_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_conv_init. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd !< Diapycnal diffusivity at each interface that !! will be incremented here [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: KV !< Viscosity at each interface that will be !! incremented here [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + 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]. diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 1df0390697..b50f4c1c88 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -60,14 +60,14 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_H !< Initial zonal velocity on T points [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: v_H !< Initial meridional velocity on T !! points [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface + 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]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface + 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]. type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. @@ -281,26 +281,26 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) CS%id_N2 = register_diag_field('ocean_model', 'N2_shear', diag%axesTi, Time, & 'Square of Brunt-Vaisala frequency used by MOM_CVMix_shear module', '1/s2', conversion=US%s_to_T**2) if (CS%id_N2 > 0) then - allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%N2(:,:,:) = 0. + allocate( CS%N2( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) ; CS%N2(:,:,:) = 0. endif CS%id_S2 = register_diag_field('ocean_model', 'S2_shear', diag%axesTi, Time, & 'Square of vertical shear used by MOM_CVMix_shear module','1/s2', conversion=US%s_to_T**2) if (CS%id_S2 > 0) then - allocate( CS%S2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%S2(:,:,:) = 0. + allocate( CS%S2( SZI_(G), SZJ_(G),SZK_(GV)+1 ) ) ; CS%S2(:,:,:) = 0. endif CS%id_ri_grad = register_diag_field('ocean_model', 'ri_grad_shear', diag%axesTi, Time, & 'Gradient Richarson number used by MOM_CVMix_shear module','nondim') if (CS%id_ri_grad > 0) then !Initialize w/ large Richardson value - allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(G)+1 )) ; CS%ri_grad(:,:,:) = 1.e8 + allocate( CS%ri_grad( SZI_(G), SZJ_(G),SZK_(GV)+1 )) ; CS%ri_grad(:,:,:) = 1.e8 endif CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & 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_(G)+1 )) ; CS%ri_grad_smooth(:,:,:) = 1.e8 + allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G),SZK_(GV)+1 )) ; CS%ri_grad_smooth(:,:,:) = 1.e8 endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1ee3fb4563..1ff12b9099 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -103,7 +103,7 @@ module MOM_diabatic_aux subroutine make_frazil(h, tv, G, GV, US, CS, 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_(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(inout) :: tv !< Structure containing pointers to any available !! thermodynamic fields. @@ -119,7 +119,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. T_freeze, & ! The freezing potential temperature at the current salinity [degC]. ps ! Surface pressure [R L2 T-2 ~> Pa] - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real :: hc ! A layer's heat capacity [Q R Z degC-1 ~> J m-2 degC-1]. @@ -226,17 +226,17 @@ end subroutine make_frazil 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 - 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: 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_(G)+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]. @@ -246,9 +246,9 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) 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]. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)+1) :: & + 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]. @@ -322,7 +322,7 @@ end subroutine differential_diffuse_T_S subroutine adjust_salt(h, tv, G, GV, CS, 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_(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(inout) :: tv !< Structure containing pointers to any !! available thermodynamic fields. @@ -379,25 +379,25 @@ end subroutine adjust_salt !> This is a simple tri-diagonal solver for T and S. !! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - integer, intent(in) :: is !< The start i-index to work on. - integer, intent(in) :: ie !< The end i-index to work on. - integer, intent(in) :: js !< The start j-index to work on. - integer, intent(in) :: je !< The end j-index to work on. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold !< The layer thicknesses before entrainment, - !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< The amount of fluid entrained from the layer - !! above within this time step [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< The amount of fluid entrained from the layer - !! below within this time step [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Layer potential temperatures [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Layer salinities [ppt]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: is !< The start i-index to work on. + integer, intent(in) :: ie !< The end i-index to work on. + integer, intent(in) :: js !< The start j-index to work on. + integer, intent(in) :: je !< The end j-index to work on. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: hold !< The layer thicknesses before entrainment, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. ! Local variables real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-2 or m2 kg-1]. real :: d1(SZIB_(G)) ! A variable used by the tridiagonal solver [nondim]. - real :: c1(SZIB_(G),SZK_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: h_tr, b_denom_1 ! Two temporary thicknesses [H ~> m or kg m-2]. integer :: i, j, k @@ -429,23 +429,23 @@ end subroutine triDiagTS !> This is a simple tri-diagonal solver for T and S, with mixing across interfaces but no net !! transfer of mass. subroutine triDiagTS_Eulerian(G, GV, is, ie, js, je, hold, ent, T, S) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - integer, intent(in) :: is !< The start i-index to work on. - integer, intent(in) :: ie !< The end i-index to work on. - integer, intent(in) :: js !< The start j-index to work on. - integer, intent(in) :: je !< The end j-index to work on. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold !< The layer thicknesses before entrainment, - !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: ent !< The amount of fluid mixed across an interface - !! within this time step [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Layer potential temperatures [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Layer salinities [ppt]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: is !< The start i-index to work on. + integer, intent(in) :: ie !< The end i-index to work on. + integer, intent(in) :: js !< The start j-index to work on. + integer, intent(in) :: je !< The end j-index to work on. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: hold !< The layer thicknesses before entrainment, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: ent !< The amount of fluid mixed across an interface + !! within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. ! Local variables real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-2 or m2 kg-1]. real :: d1(SZIB_(G)) ! A variable used by the tridiagonal solver [nondim]. - real :: c1(SZIB_(G),SZK_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: h_tr, b_denom_1 ! Two temporary thicknesses [H ~> m or kg m-2]. integer :: i, j, k @@ -481,21 +481,21 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: u_h !< Zonal velocity interpolated to h points [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: v_h !< Meridional velocity interpolated to h points [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: ea !< The amount of fluid entrained from the layer !! above within this time step [H ~> m or kg m-2]. !! Omitting ea is the same as setting it to 0. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. !! Omitting eb is the same as setting it to 0. @@ -507,7 +507,9 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) 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)), d1(SZI_(G)), c1(SZI_(G),SZK_(G)) + 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. @@ -637,7 +639,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity_CSp, tracer_ if (.not.associated(tracer_flow_CSp)) call MOM_error(FATAL, & "The tracer flow control structure must be associated when the model sets "//& "the chlorophyll internally in set_pen_shortwave.") - call get_chl_from_model(chl_3d, G, tracer_flow_CSp) + call get_chl_from_model(chl_3d, G, GV, tracer_flow_CSp) if (CS%id_chl > 0) call post_data(CS%id_chl, chl_3d(:,:,1), CS%diag) @@ -660,7 +662,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, 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 integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 !! available thermodynamic fields. @@ -812,7 +814,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 !! available thermodynamic fields. @@ -820,7 +822,7 @@ 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_(G)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD + real, dimension(SZK_(GV)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD real, dimension(3) :: PE_threshold real :: ig, E_g @@ -1004,7 +1006,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t type(optics_type), pointer :: optics !< Optical properties container integer, intent(in) :: nsw !< The number of frequency bands of penetrating !! shortwave radiation - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any !! available thermodynamic fields. @@ -1013,13 +1015,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! can be evaporated in one time-step [nondim]. real, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! heat and freshwater fluxes is applied [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix !! forcing through each layer [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with !! potential temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with !! salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & @@ -1055,7 +1057,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] - real, dimension(SZI_(G), SZK_(G)) :: & + 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 [degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within @@ -1069,7 +1071,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [degC H ~> degC m or degC kg m-2] Pen_SW_bnd_rate ! The penetrative shortwave heating rate by band ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - real, dimension(max(nsw,1),SZI_(G),SZK_(G)) :: & + real, dimension(max(nsw,1),SZI_(G),SZK_(GV)) :: & opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index ee04b841c4..a558f9dd2b 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -52,7 +52,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & 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 containing pointers to any available !! thermodynamic fields. Absent fields have NULL @@ -62,20 +62,20 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, intent(in) :: dt !< The time increment [T ~> s]. type(entrain_diffusive_CS), pointer :: CS !< The control structure returned by a previous !! call to entrain_diffusive_init. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: ea !< The amount of fluid entrained from the layer !! above within this time step [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & 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 !! the buffer layer. ! At least one of the two following arguments must be present. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers !! [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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]. @@ -85,11 +85,11 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! differences between layers. The scheme that is used here is described in ! detail in Hallberg, Mon. Wea. Rev. 2000. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & dtKd ! The layer diapycnal diffusivity times the time step [H2 ~> m2 or kg2 m-4]. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & dtKd_int ! The diapycnal diffusivity at the interfaces times the time step [H2 ~> m2 or kg2 m-4] - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & F, & ! The density flux through a layer within a time step divided by the ! density difference across the interface below the layer [H ~> m or kg m-2]. maxF, & ! maxF is the maximum value of F that will not deplete all of the @@ -102,7 +102,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & h_guess ! An estimate of the layer thicknesses after entrainment, but ! before the entrainments are adjusted to drive the layer ! densities toward their target values [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & Ent_bl ! The average entrainment upward and downward across ! each interface around the buffer layers [H ~> m or kg m-2]. real, allocatable, dimension(:,:,:) :: & @@ -114,8 +114,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: hm, fm, fr, fk ! Work variables with units of H, H, H, and H2. - real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. + 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] real, dimension(SZI_(G)) :: & htot, & ! The total thickness above or below a layer [H ~> m or kg m-2]. @@ -148,7 +148,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & maxF_kb, & ! The maximum value of F_kb that might be realized [H ~> m or kg m-2]. eakb_maxF, & ! The value of eakb that gives F_kb=maxF_kb [H ~> m or kg m-2]. F_kb_maxEnt ! The value of F_kb when eakb = max_eakb [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & Sref, & ! The reference potential density of the mixed and buffer layers, ! and of the two lightest interior layers (kb and kb+1) copied ! into layers kmb+1 and kmb+2 [R ~> kg m-3]. @@ -156,7 +156,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! lightest interior layers (kb and kb+1) copied into layers kmb+1 ! and kmb+2 [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & ds_dsp1, & ! The coordinate variable (sigma-2) difference across an ! interface divided by the difference across the interface ! below it. [nondim] @@ -894,30 +894,30 @@ end subroutine entrainment_diffusive subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do_i_in) 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),SZK_(G)), intent(in) :: F !< The density flux through a layer within + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: F !< The density flux through a layer within !! a time step divided by the density !! difference across the interface below !! the layer [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 !< Layer thicknesses [H ~> m or kg m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< The index of the lightest layer denser than !! the deepest buffer layer. integer, intent(in) :: kmb !< The number of mixed and buffer layers. integer, intent(in) :: j !< The meridional index upon which to work. type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: dsp1_ds !< The ratio of coordinate variable + 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. 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_(G)), intent(in) :: Ent_bl !< The average entrainment upward and + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around !! the buffer layers [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid entrained from the layer !! above within this time step [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. logical, dimension(SZI_(G)), & @@ -1024,9 +1024,9 @@ end subroutine F_to_ent subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, Sref, 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: dtKd_int !< The diapycnal diffusivity across !! each interface times the time step !! [H2 ~> m2 or kg2 m-4]. @@ -1042,13 +1042,13 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. integer, intent(in) :: j !< The meridional index upon which to work. - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Ent_bl !< The average entrainment upward and !! downward across each interface around !! the buffer layers [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)), intent(out) :: Sref !< The coordinate potential density minus + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Sref !< The coordinate potential density minus !! 1000 for each layer [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)), intent(out) :: h_bl !< The thickness of each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: h_bl !< The thickness of each layer [H ~> m or kg m-2]. ! This subroutine sets the average entrainment across each of the interfaces ! between buffer layers within a timestep. It also causes thin and relatively @@ -1064,7 +1064,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, pres, & ! Reference pressure (P_Ref) [R L2 T-2 ~> Pa]. frac_rem, & ! The fraction of the diffusion remaining [nondim]. h_interior ! The interior thickness available for entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G), SZK_(G)) :: & + 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]. @@ -1201,9 +1201,9 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & 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),SZK_(G)), intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< Reference potential density [R ~> kg m-3] - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Sref !< Reference potential density [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface !! around the buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: E_kb !< The entrainment by the top interior @@ -1248,7 +1248,7 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & ! also be returned. ! Local variables - real, dimension(SZI_(G),SZK_(G)) :: & + 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. @@ -1440,14 +1440,14 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & G, GV, CS, ea_kb, tol_in) 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),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h_bl !< Layer thickness, with the top interior !! layer at k-index kmb+1 [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Sref !< The coordinate reference potential density, !! with the value of the topmost interior layer !! at index kmb+1 [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Ent_bl !< The average entrainment upward and downward !! across each interface around the buffer layers, !! [H ~> m or kg m-2]. @@ -1573,13 +1573,13 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & error, err_min_eakb0, err_max_eakb0, F_kb, dFdfm_kb) 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),SZK_(G)), intent(in) :: h_bl !< Layer thickness, with the top interior + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h_bl !< Layer thickness, with the top interior !! layer at k-index kmb+1 [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< The coordinate reference potential + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Sref !< The coordinate reference potential !! density, with the value of the !! topmost interior layer at layer !! kmb+1 [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around !! the buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in @@ -1785,11 +1785,11 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & F_lim_maxent, F_thresh) 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),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Sref !< Reference potential density [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around !! the buffer layers [H ~> m or kg m-2]. diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index d9c0a76b43..ceb77b52b8 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -23,13 +23,13 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: T_adj !< Adjusted potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: S_adj !< Adjusted salinity [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 @@ -39,7 +39,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, integer, optional, intent(in) :: halo !< Halo width over which to compute ! Local variables - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & dRho_dT, & ! The derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS ! The derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: h_neglect, h0 ! A thickness that is so small it is usually lost @@ -54,7 +54,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, ! mixing with layers above rescaled by a factor of d_a [ppt]. ! This array is discreted on tracer cells, but contains an extra ! layer at the top for algorithmic convenience. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & Te_b, & ! A partially updated temperature estimate including the influnce from ! mixing with layers below rescaled by a factor of d_b [degC]. ! This array is discreted on tracer cells, but contains an extra @@ -63,7 +63,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, ! mixing with layers below rescaled by a factor of d_b [ppt]. ! This array is discreted on tracer cells, but contains an extra ! layer at the bottom for algorithmic convenience. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & c_a, & ! The fractional influence of the properties of the layer below ! in the final properies with a downward-first solver, nondim. d_a, & ! The fractional influence of the properties of the layer in question @@ -74,7 +74,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, d_b ! The fractional influence of the properties of the layer in question ! and layers below in the final properies with a upward-first solver, nondim. ! d_b = 1.0 - c_b - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & mix !< The amount of mixing across the interface between layers [H ~> m or kg m-2]. real :: mix_len ! The length-scale of mixing, when it is active [H ~> m or kg m-2] real :: h_b, h_a ! The thicknessses of the layers above and below an interface [H ~> m or kg m-2] @@ -322,15 +322,15 @@ end function is_unstable subroutine smoothed_dRdT_dRdS(h, 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_(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 real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dT !< Derivative of locally referenced !! potential density with temperature [R degC-1 ~> kg m-3 degC-1] - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dS !< Derivative of locally referenced !! potential density with salinity [R degC-1 ~> kg m-3 ppt-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -339,12 +339,12 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h integer, optional, intent(in) :: halo !< Halo width over which to compute ! Local variables - real :: mix(SZI_(G),SZK_(G)+1) ! The diffusive mixing length (kappa*dt)/dz + real :: mix(SZI_(G),SZK_(GV)+1) ! The diffusive mixing length (kappa*dt)/dz ! between layers within 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_(G)) ! tridiagonal solver. - real :: T_f(SZI_(G),SZK_(G)) ! Filtered temperatures [degC] - real :: S_f(SZI_(G),SZK_(G)) ! Filtered salinities [ppt] + real :: c1(SZI_(G),SZK_(GV)) ! tridiagonal solver. + real :: T_f(SZI_(G),SZK_(GV)) ! Filtered temperatures [degC] + real :: S_f(SZI_(G),SZK_(GV)) ! Filtered salinities [ppt] real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [degC] real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [ppt] diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index ceadaff821..63a937c240 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -51,27 +51,25 @@ module MOM_geothermal !! or very small, the layers are simply heated in place. Any heat that can not !! be applied to the ocean is returned (WHERE)? subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers - !! to any available thermodynamic - !! fields. Absent fields have NULL - !! ptrs. - real, intent(in) :: dt !< Time increment [T ~> s]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea !< The amount of fluid moved - !! downward into a layer; this - !! should be increased due to mixed - !! layer detrainment [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: eb !< The amount of fluid moved upward - !! into a layer; this should be - !! increased due to mixed layer - !! entrainment [H ~> m or kg m-2]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(geothermal_CS), pointer :: CS !< The control structure returned by - !! a previous call to - !! geothermal_init. - integer, optional, intent(in) :: halo !< Halo width over which to work + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), 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. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: ea !< The amount of fluid moved + !! downward into a layer; this + !! should be increased due to mixed + !! layer detrainment [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: eb !< The amount of fluid moved upward + !! into a layer; this should be + !! increased due to mixed layer + !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(geothermal_CS), pointer :: CS !< The control structure returned by + !! a previous call to + !! geothermal_init. + integer, optional, intent(in) :: halo !< Halo width over which to work ! Local variables real, dimension(SZI_(G)) :: & heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] @@ -106,15 +104,10 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) real :: Irho_cp ! inverse of heat capacity per unit layer volume ! [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_old ! Temperature of each layer - ! before any heat is added, - ! for diagnostics [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_old ! Thickness of each layer - ! before any heat is added, - ! for diagnostics [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d ! Scratch variable used to - ! calculate change in heat - ! due to geothermal + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T_old, & ! Temperature of each layer before any heat is added, for diagnostics [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 real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_i(SZI_(G)) @@ -368,18 +361,16 @@ end subroutine geothermal_entraining !! the bottom, by simply heating the water in place. Any heat that can not be applied to the ocean !! is returned (WHERE)? subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: 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. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(geothermal_CS), pointer :: CS !< The control structure returned by - !! a previous call to geothermal_init. - integer, optional, intent(in) :: halo !< Halo width over which to work + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: 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. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(geothermal_CS), pointer :: CS !< The control structure returned by + !! a previous call to geothermal_init. + integer, optional, intent(in) :: halo !< Halo width over which to work ! Local variables real, dimension(SZI_(G)) :: & @@ -392,7 +383,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) real :: Irho_cp ! inverse of heat capacity per unit layer volume ! [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dTdt_diag ! Diagnostic of temperature tendency [degC T-1 ~> degC s-1] which might be ! converted into a layer-integrated heat tendency [Q R Z T-1 ~> W m-2] real :: Idt ! inverse of the timestep [T-1 ~> s-1] diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 9ab9a7fc34..60de9bd0e9 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -72,24 +72,24 @@ module MOM_int_tide_input !> Sets the model-state dependent internal tide energy sources. subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) - 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(SZIB_(G),SZJ_(G),SZK_(G)), 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, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the - !! thermodynamic fields - type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related - !! to the internal tide sources. - real, intent(in) :: dt !< The time increment [T ~> s]. - type(int_tide_input_CS), pointer :: CS !< This module's 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the + !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related + !! to the internal tide sources. + real, intent(in) :: dt !< The time increment [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),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [degC] and [ppt] with the values in ! the massless layers filled vertically by diffusion. logical :: use_EOS ! If true, density is calculated from T & S using an @@ -148,23 +148,23 @@ 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) - 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)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the - !! thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_f !< Temperature after vertical filtering to - !! smooth out the values in thin layers [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_f !< Salinity after vertical filtering to - !! smooth out the values in thin layers [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 - type(int_tide_input_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the + 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 containing pointers to the + !! thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to + !! smooth out the values in thin layers [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to + !! smooth out the values in thin layers [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 + type(int_tide_input_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the !! ocean bottom [T-2 ~> s-2]. ! Local variables - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. real, dimension(SZI_(G)) :: & pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 625b6e34c4..f67fb48fc7 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -71,17 +71,17 @@ module MOM_regularize_layers subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. real, intent(in) :: dt !< Time increment [T ~> s]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed !! layer detrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & 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]. @@ -108,17 +108,17 @@ end subroutine regularize_layers subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. real, intent(in) :: dt !< Time increment [T ~> s]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed !! layer detrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & 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]. @@ -132,12 +132,12 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) def_rat_v ! The ratio of the thickness deficit to the minimum depth [nondim]. real, dimension(SZI_(G),SZJ_(G)) :: & def_rat_h ! The ratio of the thickness deficit to the minimum depth [nondim]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & e ! The interface depths [H ~> m or kg m-2], positive upward. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-d version of h [H ~> m or kg m-2]. T_2d, & ! A 2-d version of tv%T [degC]. S_2d, & ! A 2-d version of tv%S [ppt]. @@ -160,7 +160,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_tot1, Th_tot1, Sh_tot1, & h_tot3, Th_tot3, Sh_tot3, & h_tot2, Th_tot2, Sh_tot2 - real, dimension(SZK_(G)) :: & + 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]. real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. @@ -170,7 +170,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) 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]. - real, dimension(SZK_(G)+1) :: & + real, dimension(SZK_(GV)+1) :: & int_flux, int_Tflux, int_Sflux, int_Rflux real :: h_add real :: h_det_tot @@ -616,7 +616,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & def_rat_u_2lay, def_rat_v_2lay, halo, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: e !< Interface depths [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), & intent(out) :: def_rat_u !< The thickness deficit ratio at u points, @@ -635,7 +635,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & !! pointswhen the mixed and buffer layers !! are aggregated into 1 layer [nondim]. integer, optional, intent(in) :: halo !< An extra-wide halo size, 0 by default. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. !! If h is not present, vertical differences !! in interface heights are used instead. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 774d050f33..7c3697550e 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -213,15 +213,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u_h !< Zonal velocity interpolated to h points [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: v_h !< Meridional velocity interpolated to h points [L T-1 ~> m s-1]. type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic !! fields. Out is for tv%TempxPmE. @@ -232,15 +232,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & !! boundary layer properies, and related fields. real, intent(in) :: dt !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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]. @@ -251,11 +251,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & type(diffusivity_diags) :: dd ! structure with arrays of available diags - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! Temperature and salinity [degC] and [ppt] with properties in massless layers ! filled vertically by diffusion or the properties after full convective adjustment. - real, dimension(SZI_(G),SZK_(G)) :: & + 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] maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] @@ -263,7 +263,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & !< TKE dissipated within a layer and Kd in that layer !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(G)+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] @@ -704,28 +704,28 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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 !< Structure containing pointers to any available !! thermodynamic fields. - real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: dRho_int !< Change in locally referenced potential density + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: dRho_int !< Change in locally referenced potential density !! across each interface [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< j-index of row to work on real, intent(in) :: dt !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd !< The conversion rate between the + 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, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(G)), intent(out) :: maxTKE !< The energy required to for a layer to entrain + 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 !! layer, or -1 without a bulk mixed layer. ! Local variables - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & ds_dsp1, & ! coordinate variable (sigma-2) difference across an ! interface divided by the difference across the interface ! below it [nondim] @@ -918,29 +918,29 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_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_(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 !< Structure containing pointers to any available !! thermodynamic fields. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: T_f !< layer temperature with the values in massless layers !! filled vertically by diffusion [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: S_f !< Layer salinities with values in massless !! layers filled vertically by diffusion [ppt]. type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes integer, intent(in) :: j !< j-index of row to work on type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dRho_int !< Change in locally referenced potential density !! across each interface [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [T-2 ~> s-2]. - real, dimension(SZI_(G),SZK_(G)), & + 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]. ! Local variables - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] dRho_dT, & ! partial derivative of density wrt temp [R degC-1 ~> kg m-3 degC-1] dRho_dS ! partial derivative of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] @@ -1091,20 +1091,20 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available !! thermodynamic fields; absent fields have NULL ptrs. - 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]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: T_f !< layer temperatures with the values in massless layers !! filled vertically by diffusion [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: S_f !< Layer salinities with values in massless !! layers filled vertically by diffusion [ppt]. integer, intent(in) :: j !< Meridional index upon which to work. type(set_diffusivity_CS), pointer :: CS !< Module control structure. - real, dimension(SZI_(G),SZK_(G)+1), & + 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]. - real, dimension(SZI_(G),SZK_(G)+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]. @@ -1177,11 +1177,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(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 !< Structure containing pointers to any available !! thermodynamic fields. @@ -1189,26 +1189,26 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields integer, intent(in) :: j !< j-index of row to work on - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + 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] - real, dimension(SZI_(G),SZK_(G)), intent(in) :: maxTKE !< The energy required to for a layer to entrain + 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_(G)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, !! [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & optional, 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]. ! This routine adds diffusion sustained by flow energy extracted by bottom drag. - real, dimension(SZK_(G)+1) :: & + real, dimension(SZK_(GV)+1) :: & Rint ! coordinate density of an interface [R ~> kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the @@ -1415,11 +1415,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< u component of flow [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< v component of flow [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 available !! thermodynamic fields. @@ -1427,13 +1427,13 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields. integer, intent(in) :: j !< j-index of row to work on - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] 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(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & optional, intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] ! Local variables @@ -1575,19 +1575,19 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(forcing), intent(in) :: fluxes !< Surface fluxes structure integer, intent(in) :: j !< The j-index to work on type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + 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] - real, dimension(SZI_(G),SZK_(G)), & + 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_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces !! [Z2 T-1 ~> m2 s-1]. @@ -1719,11 +1719,11 @@ subroutine set_BBL_TKE(u, v, h, 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom @@ -1903,7 +1903,7 @@ end subroutine set_BBL_TKE subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) 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 !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields; absent @@ -1914,20 +1914,20 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) type(set_diffusivity_CS), pointer :: CS !< Control structure returned by previous !! call to diabatic_entrain_init. integer, intent(in) :: j !< Meridional index upon which to work. - real, dimension(SZI_(G),SZK_(G)), intent(out) :: ds_dsp1 !< Coordinate variable (sigma-2) + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: ds_dsp1 !< Coordinate variable (sigma-2) !! difference across an interface divided by !! the difference across the interface below !! it [nondim] - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZK_(GV)), & optional, intent(in) :: rho_0 !< Layer potential densities relative to !! surface press [R ~> kg m-3]. ! 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 temproray variables - real :: a(SZK_(G)), a_0(SZK_(G)) ! nondimensional temporary variables + real :: eps, tmp ! nondimensional temporary variables + real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] - real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] + 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] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 8d4704f516..6ff8faf2f0 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -193,11 +193,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(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 containing pointers to any !! available thermodynamic fields. Absent fields @@ -235,7 +235,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) D_v, & ! Bottom depth interpolated to v points [Z ~> m]. mask_v ! A mask that disables any contributions from v points that ! are land or past open boundary conditions [nondim], 0 or 1. - real, dimension(SZIB_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZK_(GV)) :: & h_at_vel, & ! Layer thickness at a velocity point, using an upwind-biased ! second order accurate estimate based on the previous velocity ! direction [H ~> m or kg m-2]. @@ -314,7 +314,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! 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]. - real :: L(SZK_(G)+1) ! The fraction of the full cell width that is open at + 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]. @@ -603,7 +603,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) hwtot = hwtot + hweight if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then - v_at_u = set_v_at_u(v, h, G, i, j, k, mask_v, OBC) + 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)) ) @@ -611,7 +611,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + & v_at_u*v_at_u + U_bg_sq) else - u_at_v = set_u_at_v(u, h, G, i, j, k, mask_u, OBC) + 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)) ) @@ -1004,13 +1004,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (m==1) then if (Rayleigh > 0.0) then - v_at_u = set_v_at_u(v, h, G, i, j, k, mask_v, OBC) + 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) 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, i, j, k, mask_u, OBC) + 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) else ; visc%Ray_v(i,J,k) = 0.0 ; endif @@ -1112,20 +1112,21 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) end subroutine set_viscous_BBL !> This subroutine finds a thickness-weighted value of v at the u-points. -function set_v_at_u(v, h, G, i, j, k, mask2dCv, OBC) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - integer, intent(in) :: i !< The i-index of the u-location to work on. - 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. +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 + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + 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] + integer, intent(in) :: i !< The i-index of the u-location to work on. + 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 - 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. + intent(in) :: mask2dCv !< A multiplicative mask of the v-points + 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. ! This subroutine finds a thickness-weighted value of v at the u-points. real :: hwt(0:1,-1:0) ! Masked weights used to average u onto v [H ~> m or kg m-2]. @@ -1156,20 +1157,21 @@ function set_v_at_u(v, h, G, i, j, k, mask2dCv, OBC) end function set_v_at_u !> This subroutine finds a thickness-weighted value of u at the v-points. -function set_u_at_v(u, h, G, i, j, k, mask2dCu, OBC) - 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] or other units. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - integer, intent(in) :: i !< The i-index of the u-location to work on. - 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. +function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) + 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 !< The zonal velocity [L T-1 ~> m s-1] or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, intent(in) :: i !< The i-index of the u-location to work on. + 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 - 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. + intent(in) :: mask2dCu !< A multiplicative mask of the u-points + 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. ! This subroutine finds a thickness-weighted value of u at the v-points. real :: hwt(-1:0,0:1) ! Masked weights used to average u onto v [H ~> m or kg m-2]. @@ -1208,11 +1210,11 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri 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(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(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 containing pointers to any available !! thermodynamic fields. Absent fields have @@ -1255,7 +1257,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri 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 :: h_at_vel(SZIB_(G),SZK_(G))! Layer thickness at velocity points, + 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]. integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found @@ -1533,7 +1535,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri hwtot = hwtot + hweight if (.not.CS%linear_drag) then - v_at_u = set_v_at_u(v, h, G, i, j, k, mask_v, OBC) + 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) endif @@ -1771,7 +1773,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri hwtot = hwtot + hweight if (.not.CS%linear_drag) then - u_at_v = set_u_at_v(u, h, G, i, J, k, mask_u, OBC) + 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) endif diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 11951e6f0c..25b5406449 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -88,18 +88,18 @@ module MOM_sponge subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & Iresttime_i_mean, int_height_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)), & intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: int_height !< The interface heights to damp back toward [Z ~> m]. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZJ_(G)), & optional, intent(in) :: Iresttime_i_mean !< The inverse of the restoring time for !! the zonal mean properties [T-1 ~> s-1]. - real, dimension(SZJ_(G),SZK_(G)+1), & + real, dimension(SZJ_(G),SZK_(GV)+1), & optional, intent(in) :: int_height_i_mean !< The interface heights toward which to !! damp the zonal mean heights [Z ~> m]. @@ -210,16 +210,17 @@ end subroutine init_sponge_diags !> This subroutine stores the reference profile for the variable !! whose address is given by f_ptr. nlay is the number of layers in !! this variable. -subroutine set_up_sponge_field(sp_val, f_ptr, G, nlay, CS, sp_val_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: sp_val !< The reference profiles of the quantity being registered. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - target, intent(in) :: f_ptr !< a pointer to the field which will be damped - 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_(G)),& +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. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: f_ptr !< a pointer to the field which will be damped + 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. @@ -324,14 +325,14 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: 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(inout) :: 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]. @@ -345,7 +346,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! there is damping. ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: & w_int, & ! Water moved upward across an interface within a timestep, ! [H ~> m or kg m-2]. e_D ! Interface heights that are dilated to have a value of 0 @@ -355,18 +356,18 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! target value [Z ~> m]. fld_anom ! Anomalies in a tracer concentration, relative to the ! i-mean target value. - real, dimension(SZJ_(G), SZK_(G)+1) :: & + 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. - real, dimension(SZI_(G), SZK_(G)+1) :: & + 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]. real, dimension(SZI_(G)) :: & dilate ! A nondimensional factor by which to dilate layers to ! give 0 at the surface [nondim]. - real :: e(SZK_(G)+1) ! The interface heights [Z ~> m], usually negative. + real :: e(SZK_(GV)+1) ! The interface heights [Z ~> m], usually negative. 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 diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9401b06662..e7f7ad9d0d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -672,26 +672,26 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C 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] real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy !! frequency [T-2 ~> s-2]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + 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_(G)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the !! interfaces [T-2 ~> s-2]. integer, intent(in) :: j !< The j-index to work on - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between 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] - real, dimension(SZI_(G),SZK_(G)), intent(in) :: max_TKE !< The energy required to for a layer to entrain + 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), pointer :: CS !< The control structure for this module - real, dimension(SZI_(G),SZK_(G)), & + 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_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal @@ -720,28 +720,28 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv 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), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. - 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]. - real, dimension(SZI_(G),SZK_(G)), & + 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_(G)+1), & + real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. ! Local variables - real, dimension(SZK_(G)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] - real, dimension(SZK_(G)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] - real, dimension(SZK_(G)+1) :: vert_dep ! vertical deposition - real, dimension(SZK_(G)+1) :: iFaceHeight ! Height of interfaces [m] - real, dimension(SZK_(G)+1) :: SchmittnerSocn - real, dimension(SZK_(G)) :: cellHeight ! Height of cell centers [m] - real, dimension(SZK_(G)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input - ! to model coordinates - real, dimension(SZK_(G)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] - real, dimension(SZK_(G)) :: Schmittner_coeff - real, dimension(SZK_(G)) :: h_m ! Cell thickness [m] + 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) :: 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)) :: h_m ! Cell thickness [m] real, allocatable, dimension(:,:) :: exp_hab_zetar integer :: i, k, is, ie @@ -959,33 +959,33 @@ end subroutine calculate_CVMix_tidal !! Froude-number-depending breaking, PSI, etc.). subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, CS, & N2_lay, Kd_lay, Kd_int, Kd_max) - 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)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency - !! frequency [T-2 ~> s-2]. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [T-2 ~> s-2]. - integer, intent(in) :: j !< The j-index to work on - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between 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] - real, dimension(SZI_(G),SZK_(G)), 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), pointer :: CS !< The control structure for this module - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. - real, intent(in) :: Kd_max !< The maximum increment for diapycnal - !! diffusivity due to TKE-based processes - !! [Z2 T-1 ~> m2 s-1]. - !! Set this to a negative value to have no limit. + 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)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency + !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between 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] + 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), pointer :: CS !< The control structure for this module + 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), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [Z2 T-1 ~> m2 s-1]. + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [Z2 T-1 ~> m2 s-1]. + !! Set this to a negative value to have no limit. ! local @@ -1498,7 +1498,7 @@ end subroutine setup_tidal_diagnostics subroutine post_tidal_diagnostics(G, GV, h ,CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(tidal_mixing_cs), pointer :: CS !< The control structure for this module diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index a41a47b254..fdf76597ef 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -188,11 +188,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(G)) ! 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_(G)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + 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 :: 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 ! is applied with direct_stress [H ~> m or kg m-2]. @@ -523,10 +523,10 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(G)) ! 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_(G)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. + 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 :: 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]. @@ -636,14 +636,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! Local variables - real, dimension(SZIB_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZK_(GV)) :: & h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. 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]. - real, dimension(SZIB_(G),SZK_(G)+1) :: & + 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_shelf, & ! The drag coefficients across interfaces in water columns under @@ -1390,8 +1390,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS real :: H_report ! A thickness below which not to report truncations. real :: dt_Rho0 ! The timestep divided by the Boussinesq density [m2 T2 s-1 L-1 Z-1 R-1 ~> s m3 kg-1]. real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1] - real :: u_old(SZIB_(G),SZJ_(G),SZK_(G)) ! The previous u-velocity [L T-1 ~> m s-1] - real :: v_old(SZI_(G),SZJB_(G),SZK_(G)) ! The previous v-velocity [L T-1 ~> m s-1] + real :: u_old(SZIB_(G),SZJ_(G),SZK_(GV)) ! The previous u-velocity [L T-1 ~> m s-1] + real :: v_old(SZI_(G),SZJB_(G),SZK_(GV)) ! The previous v-velocity [L T-1 ~> m s-1] logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G)) 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 diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 7396a4092a..b9e9196ffa 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -147,7 +147,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & 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_(G)), 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(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -173,7 +173,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & real :: tr_y ! Initial zonally uniform tracer concentrations. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: e(SZK_(G)+1), e_top, e_bot ! Heights [Z ~> m]. + real :: e(SZK_(GV)+1), e_top, e_bot ! Heights [Z ~> m]. real :: d_tr ! A change in tracer concentraions, in tracer units. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -269,7 +269,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! This is needed to force the compiler not to do a copy in the sponge ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - call set_up_sponge_field(temp, tr_ptr, G, nz, sponge_CSp) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo deallocate(temp) endif @@ -286,15 +286,15 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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]. @@ -310,9 +310,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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 @@ -338,14 +336,15 @@ end subroutine DOME_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine DOME_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to DOME_register_tracer. +subroutine DOME_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 349154cfe6..ce997d6af1 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -153,7 +153,7 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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_(G)), 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(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies @@ -179,7 +179,6 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: e(SZK_(G)+1), e_top, e_bot, d_tr integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -249,15 +248,15 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G 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]. @@ -276,9 +275,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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] real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] character(len=256) :: mesg ! The text of an error message @@ -325,14 +322,15 @@ end subroutine ISOMIP_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine ISOMIP_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to ISOMIP_register_tracer. +subroutine ISOMIP_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index cdcd121a2c..cd42011c41 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -320,7 +320,7 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, 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(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -360,16 +360,16 @@ end subroutine initialize_OCMIP2_CFC !>This subroutine initializes a tracer array. subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr !< The tracer concentration array - 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 - type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a - !! previous call to register_OCMIP2_CFC. + 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(out) :: tr !< The tracer concentration array + 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 + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine initializes a tracer array. @@ -411,15 +411,15 @@ subroutine OCMIP2_CFC_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]. @@ -442,13 +442,11 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G),SZJ_(G)) :: & CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in the CFC12_flux ! units of CFC concentrations times meters per second. real, pointer, dimension(:,:,:) :: CFC11 => NULL(), CFC12 => NULL() - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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, m, is, ie, js, je, nz, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -497,7 +495,7 @@ end subroutine OCMIP2_CFC_column_physics function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. @@ -543,14 +541,15 @@ end function OCMIP2_CFC_stock !> This subroutine extracts the surface CFC concentrations and other fields that !! are shared with the atmosphere to calculate CFC fluxes. -subroutine OCMIP2_CFC_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_OCMIP2_CFC. +subroutine OCMIP2_CFC_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_OCMIP2_CFC. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 29a575af77..ce4f6308b2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -235,7 +235,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(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(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, @@ -398,14 +398,14 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, 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 !< The amount of fluid entrained from the layer !! above during this call [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 !< The amount of fluid entrained from the layer !! below during this call [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic @@ -435,7 +435,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, real :: sosga real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke) :: rho_dzt, dzt - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work integer :: i, j, k, isc, iec, jsc, jec, nk isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke @@ -570,7 +570,7 @@ end subroutine MOM_generic_tracer_column_physics function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. @@ -721,7 +721,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(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 diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 547385c5b5..f928c78274 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -138,7 +138,7 @@ 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_(G)), & + 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] @@ -149,12 +149,12 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial - real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions - real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),2) :: ppoly0_E !< Edge values from reconstructions + real, dimension(SZK_(GV),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uFlx !< Zonal flux of tracer [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vFlx !< Meridional flux of tracer [conc m^3] real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 5d5acf3e1b..a1d7d2fc9d 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -246,24 +246,24 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, ! call closeParameterBlock(param_file) if (CS%continuous_reconstruction) then CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections - allocate(CS%dRdT(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%dRdT(:,:,:) = 0. - allocate(CS%dRdS(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%dRdS(:,:,:) = 0. + allocate(CS%dRdT(SZI_(G),SZJ_(G),SZK_(GV)+1)) ; CS%dRdT(:,:,:) = 0. + allocate(CS%dRdS(SZI_(G),SZJ_(G),SZK_(GV)+1)) ; CS%dRdS(:,:,:) = 0. else CS%nsurf = 4*GV%ke ! Discontinuous means that every interface has four connections - allocate(CS%T_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%T_i(:,:,:,:) = 0. - allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%S_i(:,:,:,:) = 0. - allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%P_i(:,:,:,:) = 0. - allocate(CS%dRdT_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdT_i(:,:,:,:) = 0. - allocate(CS%dRdS_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdS_i(:,:,:,:) = 0. - allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. - allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1)) ; CS%ppoly_coeffs_S(:,:,:,:) = 0. + allocate(CS%T_i(SZI_(G),SZJ_(G),SZK_(GV),2)) ; CS%T_i(:,:,:,:) = 0. + allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(GV),2)) ; CS%S_i(:,:,:,:) = 0. + allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(GV),2)) ; CS%P_i(:,:,:,:) = 0. + allocate(CS%dRdT_i(SZI_(G),SZJ_(G),SZK_(GV),2)) ; CS%dRdT_i(:,:,:,:) = 0. + allocate(CS%dRdS_i(SZI_(G),SZJ_(G),SZK_(GV),2)) ; CS%dRdS_i(:,:,:,:) = 0. + allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(GV),CS%deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. + allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(GV),CS%deg+1)) ; CS%ppoly_coeffs_S(:,:,:,:) = 0. allocate(CS%ns(SZI_(G),SZJ_(G))) ; CS%ns(:,:) = 0. endif ! T-points - allocate(CS%Tint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Tint(:,:,:) = 0. - allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Sint(:,:,:) = 0. - allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Pint(:,:,:) = 0. - allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(G))) ; CS%stable_cell(:,:,:) = .true. + allocate(CS%Tint(SZI_(G),SZJ_(G),SZK_(GV)+1)) ; CS%Tint(:,:,:) = 0. + allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(GV)+1)) ; CS%Sint(:,:,:) = 0. + allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(GV)+1)) ; CS%Pint(:,:,:) = 0. + allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(GV))) ; CS%stable_cell(:,:,:) = .true. ! U-points allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. @@ -282,13 +282,13 @@ 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) - 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_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity [ppt] - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion 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 thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S !< Salinity [ppt] + 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] @@ -296,7 +296,7 @@ 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_(G),2) :: ppoly_r_S ! Reconstruction slopes + 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 @@ -530,7 +530,7 @@ end subroutine neutral_diffusion_calc_coeffs 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_(G)), 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] 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] diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 119ad555da..6900f76fa5 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -45,13 +45,13 @@ module MOM_offline_aux subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: uhtr !< Accumulated mass flux through zonal face [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vhtr !< Accumulated mass flux through meridional face [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_pre !< Previous layer thicknesses [kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. ! Local variables @@ -83,16 +83,16 @@ end subroutine update_h_horizontal_flux subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: ea !< Mass of fluid entrained from the layer !! above within this timestep [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: eb !< Mass of fluid entrained from the layer !! below within this timestep [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_pre !< Layer thicknesses at the end of the previous !! step [kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. ! Local variables @@ -136,23 +136,23 @@ end subroutine update_h_vertical_flux subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uh !< Mass flux through zonal face [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vh !< Mass flux through meridional face [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< Mass of fluid entrained from the layer !! above within this timestep [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< Mass of fluid entrained from the layer !! below within this timestep [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_pre !< Layer thicknesses at the end of the previous !! step [kg m-2]. ! Local variables integer :: i, j, k, m, is, ie, js, je, nz - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: top_flux, bottom_flux + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: top_flux, bottom_flux real :: pos_flux, hvol, h_neglect, scale_factor, max_off_cfl max_off_cfl =0.5 @@ -239,15 +239,15 @@ end subroutine limit_mass_flux_3d subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end !! of the previous timestep [kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uh !< Zonal mass transport within a timestep [kg] - real, dimension(SZIB_(G),SZK_(G)) :: uh2d + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d real, dimension(SZIB_(G)) :: uh2d_sum - real, dimension(SZI_(G),SZK_(G)) :: h2d + real, dimension(SZI_(G),SZK_(GV)) :: h2d real, dimension(SZI_(G)) :: h2d_sum integer :: i, j, k, m, is, ie, js, je, nz @@ -310,15 +310,15 @@ end subroutine distribute_residual_uh_barotropic subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end !! of the previous timestep [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vh !< Meridional mass transport within a timestep [kg] - real, dimension(SZJB_(G),SZK_(G)) :: vh2d + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d real, dimension(SZJB_(G)) :: vh2d_sum - real, dimension(SZJ_(G),SZK_(G)) :: h2d + real, dimension(SZJ_(G),SZK_(GV)) :: h2d real, dimension(SZJ_(G)) :: h2d_sum integer :: i, j, k, m, is, ie, js, je, nz @@ -383,14 +383,14 @@ end subroutine distribute_residual_vh_barotropic subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end !! of the previous timestep [kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uh !< Zonal mass transport within a timestep [kg] - real, dimension(SZIB_(G),SZK_(G)) :: uh2d - real, dimension(SZI_(G),SZK_(G)) :: h2d + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d + real, dimension(SZI_(G),SZK_(GV)) :: h2d real :: uh_neglect, uh_remain, uh_add, uh_sum, uh_col, uh_max real :: hup, hdown, hlos, min_h @@ -479,15 +479,15 @@ end subroutine distribute_residual_uh_upwards subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) type(ocean_grid_type), pointer :: G !< ocean grid structure type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end !! of the previous timestep [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vh !< Meridional mass transport within a timestep [kg] - real, dimension(SZJB_(G),SZK_(G)) :: vh2d + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d real, dimension(SZJB_(G)) :: vh2d_sum - real, dimension(SZJ_(G),SZK_(G)) :: h2d + real, dimension(SZJ_(G),SZK_(GV)) :: h2d real, dimension(SZJ_(G)) :: h2d_sum real :: vh_neglect, vh_remain, vh_col, vh_sum @@ -635,19 +635,19 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ character(len=*), intent(in ) :: sum_file !< Name of file with summed fields character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields character(len=*), intent(in ) :: surf_file !< Name of file with surface fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uhtr !< Zonal mass fluxes [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vhtr !< Meridional mass fluxes [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h_end !< End of timestep layer thickness - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: temp_mean !< Averaged temperature - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: salt_mean !< Averaged salinity real, dimension(SZI_(G),SZJ_(G)), & intent(inout) :: mld !< Averaged mixed layer depth - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: Kd !< Diapycnal diffusivities at interfaces type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files @@ -769,14 +769,14 @@ subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_ character(len=200), intent(in ) :: mean_file !< Name of file with averages fields character(len=200), intent(in ) :: sum_file !< Name of file with summed fields character(len=200), intent(in ) :: snap_file !< Name of file with snapshot fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Zonal mass fluxes [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Meridional mass fluxes [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hend !< End of timestep layer thickness [kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hend !< End of timestep layer thickness [kg m-2] real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes [kg] real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes [kg] real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: temp !< Temperature array - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: salt !< Salinity array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: temp !< Temperature array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 7b1ae7bb2d..ca8d1fdde8 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -212,12 +212,12 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock real, intent(in) :: time_interval !< time interval type(offline_transport_CS), pointer :: CS !< control structure for offline module integer, intent(in) :: id_clock_ALE !< Clock for ALE routines - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: h_pre !< layer thicknesses before advection !! [H ~> m or kg m-2] - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: uhtr !< Zonal mass transport [H m2 ~> m3 or kg] - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), & intent(inout) :: vhtr !< Meridional mass transport [H m2 ~> m3 or kg] logical, intent( out) :: converged !< True if the iterations have converged @@ -227,14 +227,14 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information ! about the vertical grid ! Work arrays for mass transports - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: uhtr_sub + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhtr_sub ! Meridional mass transports - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)) :: vhtr_sub + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhtr_sub real :: prev_tot_residual, tot_residual ! Used to keep track of how close to convergence we are ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & h_new, & h_vol ! Fields for eta_diff diagnostic @@ -421,11 +421,11 @@ end subroutine offline_advection_ale !! eventually work down the entire water column subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), & intent(inout) :: vhtr !< Meridional mass transport logical, intent(in ) :: converged !< True if the iterations have converged @@ -435,14 +435,14 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) ! about the vertical grid logical :: x_before_y ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & h_new, & h_vol ! Used to calculate the eta diagnostics real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_work - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: uhr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)) :: vhr !< Meridional mass transport + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhr !< Zonal mass transport + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhr !< Meridional mass transport character(len=256) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, iter @@ -617,8 +617,8 @@ end subroutine offline_redistribute_residual !> Sums any non-negligible remaining transport to check for advection convergence real function remaining_transport_sum(CS, uhtr, vhtr) type(offline_transport_CS), pointer :: CS !< control structure for offline module - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(in ) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), intent(in ) :: vhtr !< Meridional mass transport + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(in ) :: uhtr !< Zonal mass transport + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(in ) :: vhtr !< Meridional mass transport ! Local variables integer :: i, j, k @@ -656,11 +656,11 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type type(time_type), intent(in) :: Time_end !< time interval type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & @@ -761,7 +761,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(forcing), intent(inout) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: in_flux_optional !< The total time-integrated amount @@ -811,7 +811,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(forcing), intent(inout) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: out_flux_optional !< The total time-integrated amount @@ -847,35 +847,35 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, 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 type(offline_transport_CS), pointer :: CS !< Control structure for offline module - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: eatr !< Entrainment from layer above - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: ebtr !< Entrainment from layer below - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), intent(inout) :: vhtr !< Meridional mass transport + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_pre !< layer thicknesses before advection + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: eatr !< Entrainment from layer above + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: ebtr !< Entrainment from layer below + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: uhtr !< Zonal mass transport + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(inout) :: vhtr !< Meridional mass transport ! Local pointers type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information ! about the vertical grid ! Remaining zonal mass transports - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: uhtr_sub + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhtr_sub ! Remaining meridional mass transports - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)) :: vhtr_sub + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhtr_sub real :: sum_abs_fluxes, sum_u, sum_v ! Used to keep track of how close to convergence we are real :: dt_offline ! Local variables ! Vertical diffusion related variables - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & eatr_sub, & ebtr_sub ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & h_new, & h_vol ! Work arrays for temperature and salinity - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: & + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & temp_old, salt_old, & temp_mean, salt_mean, & zero_3dh ! @@ -1017,12 +1017,12 @@ end subroutine offline_advection_layer !! read during initialization. Then if in an ALE-dependent coordinate, regrid/remap fields. subroutine update_offline_fields(CS, h, fluxes, do_ale) type(offline_transport_CS), pointer :: CS !< Control structure for offline module - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: h !< The regridded layer thicknesses + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: h !< The regridded layer thicknesses type(forcing), intent(inout) :: fluxes !< Pointers to forcing fields logical, intent(in ) :: do_ale !< True if using ALE ! Local variables integer :: i, j, k, is, ie, js, je, nz - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: h_start + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: h_start is = CS%G%isc ; ie = CS%G%iec ; js = CS%G%jsc ; je = CS%G%jec ; nz = CS%GV%ke call cpu_clock_begin(CS%id_clock_read_fields) @@ -1170,10 +1170,10 @@ end subroutine register_diags_offline_transport !> Posts diagnostics related to offline convergence diagnostics subroutine post_offline_convergence_diags(CS, h_off, h_end, uhtr, vhtr) type(offline_transport_CS), intent(in ) :: CS !< Offline control structure - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_off !< Thicknesses at end of offline step - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_end !< Stored thicknesses - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: uhtr !< Remaining zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), intent(inout) :: vhtr !< Remaining meridional mass transport + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_off !< Thicknesses at end of offline step + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_end !< Stored thicknesses + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: uhtr !< Remaining zonal mass transport + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(inout) :: vhtr !< Remaining meridional mass transport real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_diff integer :: i, j, k diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 17b34e210e..1e79061dcd 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -33,9 +33,9 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va 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(out) :: tr !< The tracer to initialize - 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] 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 @@ -64,7 +64,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va z2 ! 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_(G)+1) ! The z-star interface heights [Z ~> m]. + real :: e(SZK_(GV)+1) ! The z-star interface heights [Z ~> m]. real :: landval ! The tracer value to use in land points. real :: sl_tr ! The normalized slope of the tracer ! within the cell, in tracer units. @@ -616,16 +616,16 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, eos, 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: temp !< potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: salt !< salinity [PSU] - real, dimension(SZK_(G)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. + real, dimension(SZK_(GV)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. 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, intent(in) :: land_fill !< land fill value - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 @@ -635,7 +635,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real, parameter :: T_max = 31.0, T_min = -2.0 ! Local variables (All of which need documentation!) - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & T, S, dT, dS, & rho, & ! Layer densities [R ~> kg m-3] hin, & ! Input layer thicknesses [H ~> m or kg m-2] diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e9c8fb0e7b..678199f9cb 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -51,37 +51,37 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & h_prev_opt, max_iter_in, x_first_in, uhr_out, vhr_out, h_out) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_end !< layer thickness after advection [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: uhtr !< accumulated volume/mass flux through zonal face [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: vhtr !< accumulated volume/mass flux through merid face [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used real, intent(in) :: dt !< time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_advect_CS), pointer :: CS !< control structure for module type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: h_prev_opt !< layer thickness before advection [H ~> m or kg m-2] integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update !! first in the x- or y-direction. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: h_out !< layer thickness before advection [H ~> m or kg m-2] type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & hprev ! cell volume at the end of previous tracer change [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & uhr ! The remaining zonal thickness flux [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & vhr ! The remaining meridional thickness fluxes [H L2 ~> m3 or kg] real :: uh_neglect(SZIB_(G),SZJ_(G)) ! uh_neglect and vh_neglect are the real :: vh_neglect(SZI_(G),SZJB_(G)) ! magnitude of remaining transports that @@ -89,12 +89,11 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & real :: landvolfill ! An arbitrary? nonzero cell volume [H L2 ~> m3 or kg]. real :: Idt ! 1/dt [T-1 ~> s-1]. - logical :: domore_u(SZJ_(G),SZK_(G)) ! domore__ indicate whether there is more - logical :: domore_v(SZJB_(G),SZK_(G)) ! advection to be done in the corresponding - ! row or column. + 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. logical :: x_first ! If true, advect in the x-direction first. integer :: max_iter ! maximum number of iterations in each layer - integer :: domore_k(SZK_(G)) + integer :: domore_k(SZK_(GV)) integer :: stencil ! stencil of the advection scheme integer :: nsten_halo ! number of stencils that fit in the halos integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, itt, ntr, do_any @@ -339,14 +338,14 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & 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(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr !< accumulated volume/mass flux through + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhr !< accumulated volume/mass flux through !! the zonal face [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_neglect !< A tiny zonal mass flux that can !! be neglected [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used - logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u !< If true, there is more advection to be + logical, dimension(SZJ_(G),SZK_(GV)), intent(inout) :: domore_u !< If true, there is more advection to be !! done in this u-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] integer, intent(in) :: ntr !< The number of tracers @@ -391,7 +390,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: fac1,u_L_in,u_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() logical :: usePLMslope - logical, dimension(SZJ_(G),SZK_(G)) :: domore_u_initial + logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x ! diagnostic at the end of this subroutine. @@ -704,14 +703,14 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhr !< accumulated volume/mass flux through + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhr !< accumulated volume/mass flux through !! the meridional face [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect !< A tiny meridional mass flux that can !! be neglected [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used - logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v !< If true, there is more advection to be + logical, dimension(SZJB_(G),SZK_(GV)), intent(inout) :: domore_v !< If true, there is more advection to be !! done in this v-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] integer, intent(in) :: ntr !< The number of tracers diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 67b7ef0497..01f9e5d5c7 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -427,10 +427,10 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim type(ocean_grid_type), intent(in ) :: G !< Grid structure type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Tr !< Tracer concentration on T-cell + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: Tr !< Tracer concentration on T-cell real, intent(in ) :: dt !< Time-step over which forcing is applied [T ~> s] type(forcing), intent(in ) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] real, 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] @@ -454,7 +454,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step netMassOut ! mass leaving ocean surface [H ~> m or kg m-2] over a time step - real, dimension(SZI_(G), SZK_(G)) :: h2d, Tr2d + real, dimension(SZI_(G),SZK_(GV)) :: h2d, Tr2d real, dimension(SZI_(G),SZJ_(G)) :: in_flux ! The total time-integrated amount of tracer! ! that enters with freshwater real, dimension(SZI_(G),SZJ_(G)) :: out_flux ! The total time-integrated amount of tracer! diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 88d42ad2b2..26ef197ae2 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -332,9 +332,10 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag end subroutine tracer_flow_control_init !> This subroutine extracts the chlorophyll concentrations from the model state, if possible -subroutine get_chl_from_model(Chl_array, G, CS) +subroutine get_chl_from_model(Chl_array, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a @@ -727,7 +728,7 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) !! describe the surface state of the ocean. 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 !< Layer thicknesses [H ~> m or kg m-2] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -737,21 +738,21 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & - call USER_tracer_surface_state(sfc_state, h, G, CS%USER_tracer_example_CSp) + call USER_tracer_surface_state(sfc_state, h, G, GV, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & - call DOME_tracer_surface_state(sfc_state, h, G, CS%DOME_tracer_CSp) + call DOME_tracer_surface_state(sfc_state, h, G, GV, CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) & - call ISOMIP_tracer_surface_state(sfc_state, h, G, CS%ISOMIP_tracer_CSp) + call ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS%ISOMIP_tracer_CSp) if (CS%use_ideal_age) & - call ideal_age_tracer_surface_state(sfc_state, h, G, CS%ideal_age_tracer_CSp) + call ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) & - call dye_tracer_surface_state(sfc_state, h, G, CS%dye_tracer_CSp) + call dye_tracer_surface_state(sfc_state, h, G, GV, CS%dye_tracer_CSp) if (CS%use_oil) & - call oil_tracer_surface_state(sfc_state, h, G, CS%oil_tracer_CSp) + call oil_tracer_surface_state(sfc_state, h, G, GV, CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) & - call advection_test_tracer_surface_state(sfc_state, h, G, CS%advection_test_tracer_CSp) + 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, CS%OCMIP2_CFC_CSp) + call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS%OCMIP2_CFC_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/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 0159e3add2..1a081f4aaf 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -105,12 +105,12 @@ module MOM_tracer_hor_diff !! 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) type(ocean_grid_type), intent(inout) :: G !< Grid type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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, intent(in) :: dt !< time step [T ~> s] type(MEKE_type), pointer :: MEKE !< MEKE type type(VarMix_CS), pointer :: VarMix !< Variable mixing type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure 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 @@ -588,7 +588,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & GV, US, CS, tv, num_itts) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, intent(in) :: dt !< time step [T ~> s] type(tracer_type), intent(inout) :: Tr(:) !< tracer array integer, intent(in) :: ntr !< number of tracers @@ -626,18 +626,18 @@ 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. - real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & + 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_(G)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R - real, dimension(SZI_(G), SZK_(G), SZJ_(G)) :: & + 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_(G), SZJ_(G)) :: & + integer, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & k0_srt ! The original k-index that each layer of the sorted column ! corresponds to. - real, dimension(SZK_(G)) :: & + 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 @@ -676,10 +676,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! The total number of pairings is usually much less than twice the number of layers, but ! the memory in these 1-d columns of pairings can be allocated generously for safety. - integer, dimension(SZK_(G)*2) :: & + integer, dimension(SZK_(GV)*2) :: & kbs_Lp, & ! The sorted indices of the Left and Right columns for kbs_Rp ! each pairing. - logical, dimension(SZK_(G)*2) :: & + logical, dimension(SZK_(GV)*2) :: & 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. diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cec419d068..e3936ecfed 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -692,7 +692,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_(G)) + real :: work(SZI_(G),SZJ_(G),SZK_(GV)) 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 @@ -821,14 +821,14 @@ end subroutine MOM_tracer_chksum !> Calculates and prints the global inventory of all tracers in the registry. subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) - character(len=*), intent(in) :: mesg !< message that appears on the chksum lines - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses - integer, intent(in) :: ntr !< number of registered tracers - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: tr_inv !< Tracer inventory + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses + integer, intent(in) :: ntr !< number of registered tracers + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv !< Tracer inventory real :: total_inv integer :: is, ie, js, je, nz integer :: i, j, k, m diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 9d0b5e4f74..d5f2b3963b 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -159,7 +159,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thickness, in 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 @@ -185,7 +185,6 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg-2]. - real :: e(SZK_(G)+1), e_top, e_bot, d_tr ! Heights [Z ~> m]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB integer :: nzdata @@ -242,7 +241,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & do m=1,1 ! This is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) - call set_up_ALE_sponge_field(temp, G, tr_ptr, sponge_CSp) + call set_up_ALE_sponge_field(temp, G, GV, tr_ptr, sponge_CSp) enddo deallocate(temp) endif @@ -257,7 +256,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & enddo ; enddo; enddo do m=1,1 tr_ptr => CS%tr(:,:,:,m) - call set_up_sponge_field(temp, tr_ptr, G, nz, layer_CSp) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, layer_CSp) enddo deallocate(temp) endif @@ -276,15 +275,15 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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]. @@ -301,9 +300,7 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, ! 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 :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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] 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 diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index b1d657d6e2..1b8f43efa6 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -170,7 +170,7 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(time_type), target, intent(in) :: day !< Time of the start of the run. 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 !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -259,15 +259,15 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, 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]. @@ -288,9 +288,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! 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 - real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. + 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 @@ -316,14 +314,15 @@ end subroutine advection_test_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine advection_test_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. +subroutine advection_test_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_advection_test_tracer. + !! call to register_advection_test_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. @@ -350,10 +349,10 @@ end subroutine advection_test_tracer_surface_state !! If the stock_index is present, only the stock corresponding to that coded index is returned. function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + 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(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index da76cb3026..1817d81744 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -155,7 +155,7 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, type(time_type), target, intent(in) :: day !< Time of the start of the run. 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 !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -208,15 +208,15 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, tv, debug, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - 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]. @@ -246,7 +246,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, real :: year, h_total, scale, htot, Ih_limit integer :: secs, days integer :: i, j, k, is, ie, js, je, nz, m, k_max - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -286,7 +286,7 @@ end subroutine boundary_impulse_tracer_column_physics function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in ) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -334,14 +334,15 @@ end function boundary_impulse_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine boundary_impulse_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. +subroutine boundary_impulse_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_boundary_impulse_tracer. + !! call to register_boundary_impulse_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index cd17415b21..4f8bbe88ac 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -247,15 +247,15 @@ subroutine dye_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]. @@ -271,7 +271,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_(G)) :: 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 real :: sfc_val ! The surface value for the tracers. real :: Isecs_per_year ! The number of seconds in a year. real :: year ! The time in years. @@ -372,14 +372,15 @@ end function dye_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine dye_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_dye_tracer. +subroutine dye_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 198ee1bc4f..c54396eee6 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -138,7 +138,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) 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_(G)), 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(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -159,7 +159,6 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: e(SZK_(G)+1), e_top, e_bot, d_tr integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -204,15 +203,15 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, 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]. @@ -228,9 +227,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 :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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 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/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index f6d98b1f0f..6689cc5149 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -201,7 +201,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, 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(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -285,15 +285,15 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, 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]. @@ -314,7 +314,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),SZK_(G)) :: 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 real :: sfc_val ! The surface 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. @@ -373,11 +373,11 @@ end subroutine ideal_age_tracer_column_physics !! has calculated. If stock_index is present, only the stock corresponding to that coded index is found. function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -420,14 +420,15 @@ end function ideal_age_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine ideal_age_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_ideal_age_tracer. +subroutine ideal_age_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 12427b7c37..ae2c71a87c 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -209,7 +209,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, 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(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -300,15 +300,15 @@ subroutine oil_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]. @@ -331,7 +331,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: Isecs_per_year = 1.0 / (365.0*86400.0) real :: year, h_total, ldecay integer :: i, j, k, is, ie, js, je, nz, m, k_max @@ -407,7 +407,7 @@ end subroutine oil_tracer_column_physics function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -454,14 +454,15 @@ end function oil_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine oil_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_oil_tracer. +subroutine oil_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 95396a3b58..5c2c1ead67 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -120,7 +120,7 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, type(time_type), target, intent(in) :: day !< Time of the start of the run. 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 !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -175,15 +175,15 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G 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]. @@ -210,7 +210,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G real :: year, h_total, scale, htot, Ih_limit integer :: secs, days integer :: i, j, k, is, ie, js, je, nz, k_max - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: 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 @@ -253,7 +253,7 @@ end subroutine pseudo_salt_tracer_column_physics function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -299,14 +299,15 @@ end function pseudo_salt_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine pseudo_salt_tracer_surface_state(sfc_state, h, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_pseudo_salt_tracer. +subroutine pseudo_salt_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. ! This particular tracer package does not report anything back to the coupler. ! The code that is here is just a rough guide for packages that would. diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index ef16cc985d..afb341ac16 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -143,7 +143,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & type(time_type), target, intent(in) :: day !< Time of the start of the run. 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 !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. @@ -233,7 +233,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! This is needed to force the compiler not to do a copy in the sponge ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - call set_up_sponge_field(temp, tr_ptr, G, nz, sponge_CSp) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo deallocate(temp) endif @@ -263,15 +263,15 @@ end subroutine USER_initialize_tracer subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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]. @@ -286,7 +286,7 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, real :: hold0(SZI_(G)) ! The original topmost layer thickness, ! with surface mass fluxes added back, m. real :: b1(SZI_(G)) ! b1 and c1 are variables used by the - real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. + real :: c1(SZI_(G),SZK_(GV)) ! tridiagonal solver. real :: d1(SZI_(G)) ! d1=1-c1 is used by the 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]. @@ -362,7 +362,7 @@ end subroutine tracer_column_physics function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. @@ -405,11 +405,12 @@ end function USER_tracer_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. -subroutine USER_tracer_surface_state(sfc_state, h, G, CS) +subroutine USER_tracer_surface_state(sfc_state, h, 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(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - 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(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to register_USER_tracer. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 46425cbb0d..a2f1fdaa62 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -225,9 +225,9 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, eqn_of_state, just_read_params) 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_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -363,18 +363,20 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC 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_(G)) ! A temporary array for temp [degC] - real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt [ppt] - real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2]. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for thickness [Z ~> m] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [ppt] + 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 inverse damping rate [T-1 ~> s-1]. - real :: S_ref, T_ref ! Reference salinity and temerature within surface layer - real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], + real :: S_ref ! Reference salinity within the surface layer [ppt] + real :: T_ref ! Reference temerature within the surface layer [degC] + real :: S_range ! Range of salinities in the vertical [ppt] + real :: T_range ! Range of temperatures in the vertical [degC] + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], ! usually negative because it is positive upward. - real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. - real :: d_eta(SZK_(G)) ! The layer thickness in a column [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_west_sponge_time_scale, dome2d_east_sponge_time_scale ! Sponge timescales [T ~> s] real :: dome2d_west_sponge_width, dome2d_east_sponge_width @@ -479,10 +481,10 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC enddo ; enddo if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T, G, tv%T, ACSp) + call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) endif if ( associated(tv%S) ) then - call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) endif else diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index e994518eff..4a42ce64ad 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -157,11 +157,11 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) type(sponge_CS), pointer :: CSp !< A pointer that is set to point to the control !! structure for this module. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. - real :: temp(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for other variables. ! + 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 :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. - real :: H0(SZK_(G)) ! Interface heights [Z ~> m]. + real :: H0(SZK_(GV)) ! Interface heights [Z ~> m]. real :: min_depth ! The minimum depth at which to apply damping [Z ~> m] real :: damp, damp_new ! Damping rates in the sponge [days] real :: e_dense ! The depth of the densest interfaces [Z ~> m] @@ -234,9 +234,9 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) call MOM_error(FATAL,"DOME_initialize_sponges is not set up for use with"//& " a temperatures defined.") ! This should use the target values of T in temp. - call set_up_sponge_field(temp, tv%T, G, nz, CSp) + call set_up_sponge_field(temp, tv%T, G, GV, nz, CSp) ! This should use the target values of S in temp. - call set_up_sponge_field(temp, tv%S, G, nz, CSp) + call set_up_sponge_field(temp, tv%S, G, GV, nz, CSp) endif end subroutine DOME_initialize_sponges @@ -260,11 +260,12 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! Local variables ! The following variables are used to set the target temperature and salinity. - real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: T0(SZK_(GV)) ! A profile of temperatures [degC] + real :: S0(SZK_(GV)) ! A profile of salinities [ppt] + real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. ! The following variables are used to set up the transport in the DOME example. real :: tr_0, y1, y2, tr_k, rst, rsb, rc, v_k, lon_im1 real :: D_edge ! The thickness [Z ~> m], of the dense fluid at the diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 4ffe8bdc35..f4778f0d9a 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -144,10 +144,10 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables - real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], ! usually negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface - ! positive upward, in depth units [Z ~> m]. + real :: 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, tmp1 real :: x real :: min_thickness, s_sur, s_bot, t_sur, t_bot @@ -255,9 +255,9 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi 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_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -277,11 +277,12 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi real :: rho_tmp logical :: just_read ! If true, just read parameters but set nothing. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. - real :: T0(SZK_(G)), S0(SZK_(G)) - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. - real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) + real :: T0(SZK_(GV)) ! A profile of temperatures [degC] + real :: S0(SZK_(GV)) ! A profile of salinities [ppt] + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + 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 degC-1 ~> kg m-3 degC-1] real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: T_Ref, S_Ref @@ -437,10 +438,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) 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_(G)) ! A temporary array for temp [degC] - real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt [ppt] - ! real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO [R ~> kg m-3] - real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [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 :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: TNUDG ! Nudging time scale [T ~> s] real :: S_sur, T_sur ! Surface salinity and temerature in sponge @@ -450,10 +451,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) real :: rho_range ! The range of densities [R ~> kg m-3] real :: dT_dz, dS_dz ! Gradients of T and S in degC/Z and PPT/Z. - real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], usually + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. - real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. + 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, z real :: rho_dummy, min_thickness, rho_tmp, xi0 character(len=40) :: verticalCoordinate, filename, state_file @@ -616,10 +617,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! The remaining calls to set_up_sponge_field can be in any order. ! if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T, G, tv%T, ACSp) + call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) endif if ( associated(tv%S) ) then - call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) endif else ! layer mode @@ -665,8 +666,8 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! apply the sponges, along with the interface heights. call initialize_sponge(Idamp, eta, G, PF, CSp, GV) ! Apply sponge in tracer fields - call set_up_sponge_field(T, tv%T, G, nz, CSp) - call set_up_sponge_field(S, tv%S, G, nz, CSp) + call set_up_sponge_field(T, tv%T, G, GV, nz, CSp) + call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) endif diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 0a46fb260d..b93007647d 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -177,7 +177,7 @@ subroutine Kelvin_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_(G)), 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(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the Kelvin example. diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index daedacf4b2..f528323fe6 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -480,7 +480,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & 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]. @@ -904,7 +904,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & real :: Dpt_LASL, ShearDirection, WaveDirection real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [m s-1] logical :: ContinueLoop, USE_MA - real, dimension(SZK_(G)) :: US_H, VS_H + real, dimension(SZK_(GV)) :: US_H, VS_H real, dimension(NumBands) :: StkBand_X, StkBand_Y integer :: KK, BB @@ -1222,11 +1222,11 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid real, intent(in) :: dt !< Time step of MOM6 [T ~> s] for explicit solver - 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] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Velocity i-component [m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< Velocity j-component [m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. @@ -1290,11 +1290,11 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid real, intent(in) :: Dt !< Time step of MOM6 [s] CHECK IF PASSING RIGHT TIMESTEP - 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] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Velocity i-component [m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< Velocity j-component [m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 4c095c0b63..93a43e4a3e 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -252,9 +252,9 @@ subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_stat real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. ! Local variables - real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], ! usually negative because it is positive upward. - real, dimension(SZK_(G)) :: h_profile ! Vector of initial thickness profile [Z ~> m]. + 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 diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 6bbe429248..8f5c6d283e 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -46,9 +46,9 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - real :: eta0(SZK_(G)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] - real :: eta_im(SZJ_(G),SZK_(G)+1) ! A temporary array for zonal-mean eta [Z ~> m] - real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] + real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m] + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] 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 center of the domain [km] @@ -216,11 +216,11 @@ 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_(G)+1) ! The 1-d nominal positions of the interfaces. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. - real :: temp(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for other variables. + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces. + 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 :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. - real :: eta_im(SZJ_(G),SZK_(G)+1) ! A temporary array for zonal-mean eta [Z ~> m]. + 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. diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 6fbe90b855..d262583a74 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -56,9 +56,9 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) !! fields, potential temperature and !! salinity or mixed layer density. !! Absent fields have NULL ptrs. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & target, intent(in) :: v !< Array with the v velocity [L T-1 ~> m s-1] type(param_file_type), intent(in) :: PF !< A structure indicating the !! open file to parse for model @@ -68,20 +68,17 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure ! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp - real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt - real :: U1(SZIB_(G),SZJ_(G),SZK_(G)) ! A temporary array for u [L T-1 ~> m s-1] - real :: V1(SZI_(G),SZJB_(G),SZK_(G)) ! A temporary array for v [L T-1 ~> m s-1] - real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt + 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 :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. - real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness at h points + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse 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] - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. - ! positive upward, in m. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [m]. logical :: sponge_uv ! Nudge velocities (u and v) towards zero real :: min_depth, dummy1, z, delta_h real :: rho_dummy, min_thickness, rho_tmp, xi0 @@ -173,34 +170,30 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) filename = trim(inputdir)//trim(state_file) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " RGC_initialize_sponges: Unable to open "//trim(filename)) - call read_data(filename,temp_var,T(:,:,:), domain=G%Domain%mpp_domain) - call read_data(filename,salt_var,S(:,:,:), domain=G%Domain%mpp_domain) + call read_data(filename, temp_var, T(:,:,:), domain=G%Domain%mpp_domain) + call read_data(filename, salt_var, S(:,:,:), domain=G%Domain%mpp_domain) if (use_ALE) then - call read_data(filename,h_var,h(:,:,:), domain=G%Domain%mpp_domain) + call read_data(filename, h_var, h(:,:,:), domain=G%Domain%mpp_domain) call pass_var(h, G%domain) call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) ! The remaining calls to set_up_sponge_field can be in any order. ! - if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T,G,tv%T,ACSp) - endif - if ( associated(tv%S) ) then - call set_up_ALE_sponge_field(S,G,tv%S,ACSp) - endif + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) if (sponge_uv) then - U1(:,:,:) = 0.0; V1(:,:,:) = 0.0 - call set_up_ALE_sponge_vel_field(U1,V1,G,u,v,ACSp) + U1(:,:,:) = 0.0 ; V1(:,:,:) = 0.0 + call set_up_ALE_sponge_vel_field(U1, V1, G, GV, u, v, ACSp) endif else ! layer mode !read eta - call read_data(filename,eta_var,eta(:,:,:), domain=G%Domain%mpp_domain) + call read_data(filename, eta_var, eta(:,:,:), domain=G%Domain%mpp_domain) ! Set the inverse damping rates so that the model will know where to ! apply the sponges, along with the interface heights. @@ -220,8 +213,8 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) endif ! Apply sponge in tracer fields - call set_up_sponge_field(T, tv%T, G, nz, CSp) - call set_up_sponge_field(S, tv%S, G, nz, CSp) + call set_up_sponge_field(T, tv%T, G, GV, nz, CSp) + call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) endif diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 4e27227da6..cd87b47621 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -113,9 +113,9 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & param_file, eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file handle type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -165,11 +165,11 @@ end subroutine Rossby_front_initialize_temperature_salinity subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + 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_(G)), & + 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_(G)), & + 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 !< A structure indicating the open file diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 66cbf7e72d..ad4eab33ff 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -43,10 +43,10 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables - real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], usually - ! negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface - ! positive upward, in depth units [Z ~> m]. + real :: e0(SZK_(GV)+1) ! 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]. real :: dRho_dS ! The partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. real :: x, y, yy @@ -54,7 +54,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read real :: min_thickness, adjustment_width, adjustment_delta real :: adjustment_deltaS real :: front_wave_amp, front_wave_length, front_wave_asym - real :: target_values(SZK_(G)+1) ! Target densities or density anomalies [R ~> kg m-3] + real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate ! This include declares and sets the variable "version". @@ -197,9 +197,9 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, G, GV, param_file eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The temperature that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), 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. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< The model thicknesses [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. type(EOS_type), pointer :: eqn_of_state !< Equation of state. @@ -216,7 +216,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, G, GV, param_file real :: xi0, xi1, dSdz, delta_S, delta_S_strat real :: adjustment_width, adjustment_deltaS real :: front_wave_amp, front_wave_length, front_wave_asym - real :: eta1d(SZK_(G)+1) + real :: eta1d(SZK_(GV)+1) logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index 4415f6bcae..b1c988e016 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -80,9 +80,9 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, GV, US, param_f type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< The model thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing T & S. diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 243e31bc4d..ed0bbbf069 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -216,11 +216,11 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature - !! that is being initialized. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being - !! initialized. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature + !! that is being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being + !! initialized [ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for !! model parameter values. @@ -230,11 +230,12 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables - real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! Reference pressure [R L2 T-2 ~> Pa]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: T0(SZK_(GV)) ! A profile of temperatures [degC] + real :: S0(SZK_(GV)) ! A profile of salinities [ppt] + real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-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 [degC]. real :: lat diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 9c9952a102..e8fe345bb0 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -278,8 +278,8 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CS enddo enddo - if (associated(tv%T)) call set_up_ALE_sponge_field(T, G, tv%T, ACSp) - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + if (associated(tv%T)) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) else call MOM_error(FATAL, "dense_water_initialize_sponges: trying to use non ALE sponge") endif diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index c0979def10..f7b647dd27 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -101,9 +101,9 @@ subroutine dumbbell_initialize_thickness ( h, G, GV, US, param_file, just_read_p logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], usually + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + 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_surf, S_range, S_ref, S_light, S_dense ! Various salinities [ppt]. @@ -211,9 +211,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -393,7 +393,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, enddo ; enddo endif - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) end subroutine dumbbell_initialize_sponges diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 96a5ec40d0..9da82cb721 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -36,10 +36,10 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface - ! positive upward [Z ~> m]. - real :: ssh_anomaly_height ! Vertical height of ssh anomaly - real :: ssh_anomaly_width ! Lateral width of anomaly + 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] logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "external_gwave_initialize_thickness" ! This subroutine's name. ! This include declares and sets the variable "version". diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 684f22fb0a..9118133108 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -88,10 +88,9 @@ subroutine seamount_initialize_thickness ( h, G, GV, US, param_file, just_read_p logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], usually + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface - ! positive upward [Z ~> m]. + 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_surf, S_range, S_ref, S_light, S_dense ! Various salinities [ppt]. real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. @@ -195,9 +194,9 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 7ab923dfea..7bf6aebf59 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -133,7 +133,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) type(shelfwave_OBC_CS), pointer :: CS !< tidal bay 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_(G)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. 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/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 4a91435cb6..e1c0a96d63 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -64,10 +64,10 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - real :: displ(SZK_(G)+1) ! The interface displacement in depth units. - real :: z_unif(SZK_(G)+1) ! Fractional uniform interface heights [nondim]. - real :: z_inter(SZK_(G)+1) ! Interface heights, in depth units. - real :: a0 ! The displacement amplitude in depth units. + 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? @@ -180,9 +180,9 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file eqn_of_state, just_read_params) 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_(G)), intent(out) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt]. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [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. diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 4d75a25695..ac6ec8c4bc 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -64,12 +64,12 @@ 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) - 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_(G)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H ~> m or kg m-2] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 real :: x, x0 ! Positions in the same units as geoLonT. diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index f2efc4cefc..e6db433f60 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -67,7 +67,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay 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_(G)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the tidal_bay example. diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 222bc1b6f2..92570e3caa 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -47,25 +47,25 @@ module user_change_diffusivity subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_add) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer 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 !< A structure containing pointers !! to any available thermodynamic !! 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_(G)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of + 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_(G)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity + 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_(G)), optional, intent(in) :: T_f !< Temperature with massless + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: T_f !< Temperature with massless !! layers filled in vertically [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: S_f !< Salinity with massless + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: S_f !< Salinity with massless !! layers filled in vertically [ppt]. - real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal + real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables - real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [R ~> kg m-3]. + 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]. real :: rho_fn ! The density dependence of the input function, 0-1 [nondim]. real :: lat_fn ! The latitude dependence of the input function, 0-1 [nondim]. diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 671663fd74..793b87f149 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -108,8 +108,8 @@ end subroutine USER_initialize_thickness subroutine USER_initialize_velocity(u, v, G, GV, US, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G), SZJB_(G), SZK_(G)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] + 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 @@ -139,8 +139,8 @@ end subroutine USER_initialize_velocity subroutine USER_init_temperature_salinity(T, S, G, GV, param_file, eqn_of_state, just_read_params) 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_(G)), intent(out) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt]. type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. From 4075e747dbae020d7254913546c147b6d7bbf1ca Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Dec 2020 06:58:38 -0500 Subject: [PATCH 066/212] Corrected non-standard line indents The MOM6 style guide clearly states that MOM6 uses a two space indent between code levels, to enhance the readability of the MOM6 code. Continuation lines are typically indented 4 or more spaces. This commit corrects several hundred lines that did not conform to this standard. All answers are bitwise identical. --- src/ALE/MOM_ALE.F90 | 8 +- src/ALE/PLM_functions.F90 | 4 +- src/ALE/regrid_interp.F90 | 2 +- src/core/MOM.F90 | 68 ++++----- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- src/core/MOM_barotropic.F90 | 6 +- src/core/MOM_forcing_type.F90 | 22 +-- src/diagnostics/MOM_debugging.F90 | 4 +- src/diagnostics/MOM_sum_output.F90 | 4 +- src/equation_of_state/MOM_EOS.F90 | 4 +- src/framework/MOM_diag_manager_wrapper.F90 | 8 +- src/framework/MOM_horizontal_regridding.F90 | 66 ++++----- src/framework/MOM_restart.F90 | 4 +- src/ice_shelf/MOM_ice_shelf.F90 | 36 ++--- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4 +- src/ice_shelf/user_shelf_init.F90 | 71 ++++----- src/initialization/MOM_grid_initialize.F90 | 4 +- .../MOM_state_initialization.F90 | 26 ++-- src/ocean_data_assim/MOM_oda_driver.F90 | 18 +-- .../lateral/MOM_thickness_diffuse.F90 | 2 +- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_shear.F90 | 10 +- .../vertical/MOM_diabatic_aux.F90 | 4 +- .../vertical/MOM_set_diffusivity.F90 | 4 +- .../vertical/MOM_tidal_mixing.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 38 ++--- src/tracer/MOM_generic_tracer.F90 | 32 ++-- src/tracer/MOM_neutral_diffusion.F90 | 6 +- src/tracer/MOM_tracer_advect.F90 | 138 +++++++++--------- src/tracer/MOM_tracer_hor_diff.F90 | 18 +-- src/tracer/RGC_tracer.F90 | 8 +- src/user/DOME2d_initialization.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 82 +++++------ src/user/Idealized_Hurricane.F90 | 28 ++-- src/user/MOM_wave_interface.F90 | 15 +- 35 files changed, 375 insertions(+), 377 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c1042107ec..627fdc9f35 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -367,9 +367,9 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. if (ice_shelf) then - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h) else - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) endif call check_grid( G, GV, h, 0. ) @@ -639,9 +639,9 @@ subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) + call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) else - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid ) + call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid ) endif ! Override old grid with new one. The new grid 'h_new' is built in diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index da60f9614a..d0f620e4a8 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -168,8 +168,8 @@ real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] ! Avoid division by zero for vanished cells - hl = h_l + h_neglect - hc = h_c + h_neglect + hl = h_l + h_neglect + hc = h_c + h_neglect ! The h2 scheme is used to compute the left edge value left_edge = (u_l*hc + u_c*hl) / (hl + hc) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 1ab225474c..0c758fadaf 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -76,7 +76,7 @@ module regrid_interp !! a third-order PPM ih4 scheme). In these cases, we resort to the simplest !! continuous linear scheme (P1M h2). subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & - ppoly0_coefs, degree, h_neglect, h_neglect_edge) + ppoly0_coefs, degree, h_neglect, h_neglect_edge) type(interp_CS_type), intent(in) :: CS !< Interpolation control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: densities !< Actual cell densities [A] diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ddd6fe6dbb..0da0f95214 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2034,14 +2034,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, 'MOM', "ICE_SHELF", use_ice_shelf, default=.false., do_not_log=.true.) if (use_ice_shelf) then - inputdir = "." ; call get_param(param_file, 'MOM', "INPUTDIR", inputdir) - inputdir = slasher(inputdir) - call get_param(param_file, 'MOM', "ICE_THICKNESS_FILE", ice_shelf_file, & - "The file from which the ice bathymetry and area are read.", & - fail_if_missing=.true.) - call get_param(param_file, 'MOM', "ICE_AREA_VARNAME", area_varname, & - "The name of the area variable in ICE_THICKNESS_FILE.", & - fail_if_missing=.true.) + inputdir = "." ; call get_param(param_file, 'MOM', "INPUTDIR", inputdir) + inputdir = slasher(inputdir) + call get_param(param_file, 'MOM', "ICE_THICKNESS_FILE", ice_shelf_file, & + "The file from which the ice bathymetry and area are read.", & + fail_if_missing=.true.) + call get_param(param_file, 'MOM', "ICE_AREA_VARNAME", area_varname, & + "The name of the area variable in ICE_THICKNESS_FILE.", & + fail_if_missing=.true.) endif @@ -2854,32 +2854,32 @@ end subroutine register_diags subroutine MOM_timing_init(CS) type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM. - id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT) - id_clock_dynamics = cpu_clock_id('Ocean dynamics', grain=CLOCK_SUBCOMPONENT) - id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) - id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) - id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) - if (.not.CS%adiabatic) then - id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) - else - id_clock_adiabatic = cpu_clock_id('(Ocean adiabatic driver)', grain=CLOCK_MODULE_DRIVER) - endif - - id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) - id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) - id_clock_pass = cpu_clock_id('(Ocean message passing *)', grain=CLOCK_MODULE) - id_clock_MOM_init = cpu_clock_id('(Ocean MOM_initialize_state)', grain=CLOCK_MODULE) - id_clock_pass_init = cpu_clock_id('(Ocean init message passing *)', grain=CLOCK_ROUTINE) - if (CS%thickness_diffuse) & - id_clock_thick_diff = cpu_clock_id('(Ocean thickness diffusion *)', grain=CLOCK_MODULE) -!if (CS%mixedlayer_restrat) & - id_clock_ml_restrat = cpu_clock_id('(Ocean mixed layer restrat)', grain=CLOCK_MODULE) - id_clock_diagnostics = cpu_clock_id('(Ocean collective diagnostics)', grain=CLOCK_MODULE) - id_clock_Z_diag = cpu_clock_id('(Ocean Z-space diagnostics)', grain=CLOCK_MODULE) - id_clock_ALE = cpu_clock_id('(Ocean ALE)', grain=CLOCK_MODULE) - if (CS%offline_tracer_mode) then - id_clock_offline_tracer = cpu_clock_id('Ocean offline tracers', grain=CLOCK_SUBCOMPONENT) - endif + id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT) + id_clock_dynamics = cpu_clock_id('Ocean dynamics', grain=CLOCK_SUBCOMPONENT) + id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) + id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) + id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) + if (.not.CS%adiabatic) then + id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) + else + id_clock_adiabatic = cpu_clock_id('(Ocean adiabatic driver)', grain=CLOCK_MODULE_DRIVER) + endif + + id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) + id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing *)', grain=CLOCK_MODULE) + id_clock_MOM_init = cpu_clock_id('(Ocean MOM_initialize_state)', grain=CLOCK_MODULE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing *)', grain=CLOCK_ROUTINE) + if (CS%thickness_diffuse) & + id_clock_thick_diff = cpu_clock_id('(Ocean thickness diffusion *)', grain=CLOCK_MODULE) + !if (CS%mixedlayer_restrat) & + id_clock_ml_restrat = cpu_clock_id('(Ocean mixed layer restrat)', grain=CLOCK_MODULE) + id_clock_diagnostics = cpu_clock_id('(Ocean collective diagnostics)', grain=CLOCK_MODULE) + id_clock_Z_diag = cpu_clock_id('(Ocean Z-space diagnostics)', grain=CLOCK_MODULE) + id_clock_ALE = cpu_clock_id('(Ocean ALE)', grain=CLOCK_MODULE) + if (CS%offline_tracer_mode) then + id_clock_offline_tracer = cpu_clock_id('Ocean offline tracers', grain=CLOCK_SUBCOMPONENT) + endif end subroutine MOM_timing_init diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index f34dcd209e..ac5cb6c84c 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -698,7 +698,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) do k=2,nz ; do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + & (GV%g_prime(K)*GV%H_to_Z) * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) - enddo ; enddo + enddo ; enddo enddo ! end of j loop endif ! use_EOS diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bad76d7bce..fa9a518e92 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1027,7 +1027,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo !$OMP parallel do default(shared) do J=js-1,je - do k=1,nz ; do i=is,ie + do k=1,nz ; do i=is,ie gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * wt_v(i,J,k) gtot_S(i,j+1) = gtot_S(i,j+1) + pbce(i,j+1,k) * wt_v(i,J,k) enddo ; enddo @@ -3079,7 +3079,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then - do n = 1, OBC%number_of_segments + do n = 1, OBC%number_of_segments segment => OBC%segment(n) 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 @@ -3133,7 +3133,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then - do n = 1, OBC%number_of_segments + do n = 1, OBC%number_of_segments segment => OBC%segment(n) 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 diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 35ea54a7ed..56fcb725cb 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1302,20 +1302,20 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! This diagnostic is rescaled to MKS units when combined. handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & - 'Evaporation/condensation at ocean surface (evaporation is negative)', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - standard_name='water_evaporation_flux', cmor_field_name='evs', & - cmor_standard_name='water_evaporation_flux', & - cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') + 'Evaporation/condensation at ocean surface (evaporation is negative)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux', cmor_field_name='evs', & + cmor_standard_name='water_evaporation_flux', & + cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') ! smg: seaice_melt field requires updates to the sea ice model handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & - diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & - cmor_field_name='fsitherm', & - cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& - cmor_long_name='water flux to ocean from sea ice melt(> 0) or form(< 0)') + diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & + cmor_field_name='fsitherm', & + cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& + cmor_long_name='water flux to ocean from sea ice melt(> 0) or form(< 0)') handles%id_precip = register_diag_field('ocean_model', 'precip', diag%axesT1, Time, & 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1') diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 43c9c8c406..fda5a97d69 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -459,8 +459,8 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) & 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() write(0,'(A130)') trim(mesg)//trim(mesg2) - redundant_prints(1) = redundant_prints(1) + 1 - endif + redundant_prints(1) = redundant_prints(1) + 1 + endif enddo ; enddo end subroutine check_redundant_sT2d diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index b79bc77e76..7d11ac0608 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -204,7 +204,7 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & !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 - energyfile = trim(energyfile) //'.'//trim(filename_appendix) + energyfile = trim(energyfile) //'.'//trim(filename_appendix) endif CS%energyfile = trim(slasher(directory))//trim(energyfile) @@ -1299,7 +1299,7 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Vid, "long_name", "Open volume below depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & + if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Vid, "units", "m3") if (status /= NF90_NOERR) call MOM_error(WARNING, & diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3d2b9dd3e9..6e74c3ffa3 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1550,12 +1550,12 @@ 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) = gsw_sr_from_sp(S(i,j,k)) + S(i,j,k) = gsw_sr_from_sp(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) = gsw_ct_from_pt(S(i,j,k), T(i,j,k)) + T(i,j,k) = gsw_ct_from_pt(S(i,j,k), T(i,j,k)) endif enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 diff --git a/src/framework/MOM_diag_manager_wrapper.F90 b/src/framework/MOM_diag_manager_wrapper.F90 index 709fd80a8e..47dc701798 100644 --- a/src/framework/MOM_diag_manager_wrapper.F90 +++ b/src/framework/MOM_diag_manager_wrapper.F90 @@ -19,8 +19,8 @@ module MOM_diag_manager_wrapper !> An integer handle for a diagnostic array returned by register_diag_field() integer function register_diag_field_array_fms(module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or !! "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field @@ -55,8 +55,8 @@ end function register_diag_field_array_fms !> An integer handle for a diagnostic scalar array returned by register_diag_field() integer function register_diag_field_scalar_fms(module_name, field_name, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 66f58b5b9d..b323cfcfd2 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -407,15 +407,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1)) allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) - start = 1; count = 1; count(1) = id + start = 1 ; count = 1 ; count(1) = id rcode = NF90_GET_VAR(ncid, dim_id(1), lon_in, start, count) if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") - start = 1; count = 1; count(1) = jd + start = 1 ; count = 1 ; count(1) = jd rcode = NF90_GET_VAR(ncid, dim_id(2), lat_in, start, count) if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") - start = 1; count = 1; count(1) = kd + start = 1 ; count = 1 ; count(1) = kd rcode = NF90_GET_VAR(ncid, dim_id(3), z_in, start, count) if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & trim(varnam//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") @@ -425,48 +425,46 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif ! extrapolate the input data to the north pole using the northerm-most latitude - add_np=.false. - jdp=jd + add_np = .false. + jdp = jd if (.not. is_ongrid) then - max_lat = maxval(lat_in) - if (max_lat < 90.0) then - add_np=.true. - jdp=jd+1 - allocate(lat_inp(jdp)) - lat_inp(1:jd)=lat_in(:) - lat_inp(jd+1)=90.0 - deallocate(lat_in) - allocate(lat_in(1:jdp)) - lat_in(:)=lat_inp(:) - endif + max_lat = maxval(lat_in) + if (max_lat < 90.0) then + add_np = .true. + jdp = jd+1 + allocate(lat_inp(jdp)) + lat_inp(1:jd) = lat_in(:) + lat_inp(jd+1) = 90.0 + deallocate(lat_in) + allocate(lat_in(1:jdp)) + lat_in(:) = lat_inp(:) + endif endif ! construct level cell boundaries as the mid-point between adjacent centers z_edges_in(1) = 0.0 do K=2,kd - z_edges_in(K)=0.5*(z_in(k-1)+z_in(k)) + z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) enddo - z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1) + z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) if (is_ongrid) then - allocate(tr_in(is:ie,js:je)) ; tr_in(:,:)=0.0 - allocate(mask_in(is:ie,js:je)) ; mask_in(:,:)=0.0 + allocate(tr_in(is:ie,js:je)) ; tr_in(:,:)=0.0 + allocate(mask_in(is:ie,js:je)) ; mask_in(:,:)=0.0 else - call horiz_interp_init() - lon_in = lon_in*PI_180 - lat_in = lat_in*PI_180 - allocate(x_in(id,jdp),y_in(id,jdp)) - call meshgrid(lon_in,lat_in, x_in, y_in) - lon_out(:,:) = G%geoLonT(:,:)*PI_180 - lat_out(:,:) = G%geoLatT(:,:)*PI_180 - allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 - allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 - allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 - allocate(last_row(id)) ; last_row(:)=0.0 + call horiz_interp_init() + lon_in = lon_in*PI_180 + lat_in = lat_in*PI_180 + allocate(x_in(id,jdp), y_in(id,jdp)) + call meshgrid(lon_in, lat_in, x_in, y_in) + lon_out(:,:) = G%geoLonT(:,:)*PI_180 + lat_out(:,:) = G%geoLatT(:,:)*PI_180 + allocate(tr_in(id,jd)) ; tr_in(:,:) = 0.0 + allocate(tr_inp(id,jdp)) ; tr_inp(:,:) = 0.0 + allocate(mask_in(id,jdp)) ; mask_in(:,:) = 0.0 + allocate(last_row(id)) ; last_row(:) = 0.0 endif - - max_depth = maxval(G%bathyT) call mpp_max(max_depth) @@ -478,7 +476,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! to define the layers do k=1,kd write(laynum,'(I8)') k ; laynum = adjustl(laynum) - mask_in=0.0 + mask_in = 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 diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 7181a1f1b9..14518c1259 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -67,8 +67,8 @@ module MOM_restart !> A structure to store information about restart fields that are no longer used type obsolete_restart - character(len=32) :: field_name !< Name of restart field that is no longer in use - character(len=32) :: replacement_name !< Name of replacement restart field, if applicable + character(len=32) :: field_name !< Name of restart field that is no longer in use + character(len=32) :: replacement_name !< Name of replacement restart field, if applicable end type obsolete_restart !> A restart registry and the control structure for restarts diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 66fd873f67..41d397abed 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1271,7 +1271,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ice shelf (every time step) from a file.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. - call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & @@ -1592,14 +1592,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_area_shelf_h = register_diag_field('ocean_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', 'meter-2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & - 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) + 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & - 'ice shelf thickness', 'm', conversion=US%Z_to_m) - CS%id_mass_flux = register_diag_field('ocean_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) + 'ice shelf thickness', 'm', conversion=US%Z_to_m) + CS%id_mass_flux = register_diag_field('ocean_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) if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw = 1000. kg m-3 meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / (1000.0*US%kg_m3_to_R) @@ -1607,27 +1607,27 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice endif CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) + 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & - 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') + 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ocean_model', 'haline_driving', CS%diag%axesT1, CS%Time, & - 'salinity in the boundary layer minus salinity at the ice-ocean interface.', 'psu') + 'salinity in the boundary layer minus salinity at the ice-ocean interface.', 'psu') CS%id_Sbdry = register_diag_field('ocean_model', 'sbdry', CS%diag%axesT1, CS%Time, & - 'salinity at the ice-ocean interface.', 'psu') + 'salinity at the ice-ocean interface.', 'psu') CS%id_u_ml = register_diag_field('ocean_model', 'u_ml', CS%diag%axesCu1, CS%Time, & - 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) + 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_v_ml = register_diag_field('ocean_model', 'v_ml', CS%diag%axesCv1, CS%Time, & - 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) + 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_exch_vel_s = register_diag_field('ocean_model', 'exch_vel_s', CS%diag%axesT1, CS%Time, & - 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_exch_vel_t = register_diag_field('ocean_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & - 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) + 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) CS%id_tfreeze = register_diag_field('ocean_model', 'tfreeze', CS%diag%axesT1, CS%Time, & - 'In Situ Freezing point at ice shelf interface', 'degC') + 'In Situ Freezing point at ice shelf interface', 'degC') CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & - 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) + 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & - 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) + 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) if (CS%active_shelf_dynamics) then CS%id_h_mask = register_diag_field('ocean_model', 'h_mask', CS%diag%axesT1, CS%Time, & 'ice shelf thickness mask', 'none') diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 0c9fe4e77e..a2c0d482cc 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2788,9 +2788,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 if (G%symmetric) then - is = isd ; js = jsd + is = isd ; js = jsd else - is = isd+1 ; js = jsd+1 + is = isd+1 ; js = jsd+1 endif do j=js,G%jed diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 54b452fc6a..122758f3cc 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -149,51 +149,52 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C do j=G%jsd,G%jed - if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+G%jdg_offset) >= G%domain%njhalo+1)) then + if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+G%jdg_offset) >= G%domain%njhalo+1)) then - do i=G%isc,G%iec + do i=G%isc,G%iec ! if (((i+G%idg_offset) <= G%domain%niglobal+G%domain%nihalo) .AND. & ! ((i+G%idg_offset) >= G%domain%nihalo+1)) then - if ((j >= G%jsc) .and. (j <= G%jec)) then - - if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then - ! Everything past the edge is open ocean. - mass_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask (i,j) = 0.0 - h_shelf (i,j) = 0.0 - else - if (G%geoLonCu(i,j) > edge_pos) then - area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & - (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) - hmask (i,j) = 2.0 - else - area_shelf_h(i,j) = G%areaT(i,j) - hmask (i,j) = 1.0 + if ((j >= G%jsc) .and. (j <= G%jec)) then + if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then + ! Everything past the edge is open ocean. + mass_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask (i,j) = 0.0 + h_shelf (i,j) = 0.0 + else + if (G%geoLonCu(i,j) > edge_pos) then + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) + hmask (i,j) = 2.0 + else + area_shelf_h(i,j) = G%areaT(i,j) + hmask (i,j) = 1.0 + endif + + if (G%geoLonT(i,j) > slope_pos) then + h_shelf (i,j) = CS%min_draft + mass_shelf(i,j) = CS%Rho_ocean * CS%min_draft + else + mass_shelf(i,j) = CS%Rho_ocean * (CS%min_draft + & + (CS%max_draft - CS%min_draft) * & + min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + h_shelf(i,j) = (CS%min_draft + & + (CS%max_draft - CS%min_draft) * & + min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + endif + endif ; endif endif - if (G%geoLonT(i,j) > slope_pos) then - h_shelf (i,j) = CS%min_draft - mass_shelf(i,j) = CS%Rho_ocean * CS%min_draft - else - mass_shelf(i,j) = CS%Rho_ocean * (CS%min_draft + & - (CS%max_draft - CS%min_draft) * & - min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) - h_shelf(i,j) = (CS%min_draft + & - (CS%max_draft - CS%min_draft) * & - min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + if ((i+G%idg_offset) == G%domain%nihalo+1) then + hmask(i-1,j) = 3.0 endif - endif ; endif ; endif - - if ((i+G%idg_offset) == G%domain%nihalo+1) then - hmask(i-1,j) = 3.0 + enddo endif - - enddo ; endif ; enddo + enddo end subroutine USER_update_shelf_mass diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 88130857c7..efee50db05 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -240,13 +240,13 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) global_indices(4) = SGdom%njglobal+SGdom%njhalo exni(:) = 2*exni(:) ; exnj(:) = 2*exnj(:) if (associated(G%domain%maskmap)) then - call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & + call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & xextent=exni,yextent=exnj, & symmetry=.true., name="MOM_MOSAIC", maskmap=G%domain%maskmap) else - call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & + call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & xextent=exni,yextent=exnj, & diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 3733dda6a4..fe3b8efd26 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -400,22 +400,22 @@ 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, & + case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, & + case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, & just_read_params=just_read) - case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, & + case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, & + case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & + case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & just_read_params=just_read) - case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & + case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & G, GV, US, PF, just_read_params=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, & + 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_params=just_read) - case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized velocity configuration "//trim(config)) end select @@ -558,7 +558,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then - call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) + call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) ! 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) & @@ -1790,9 +1790,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L "performs on-the-fly regridding in lat-lon-time.",& "of sponge restoring data.", default=.false.) if (time_space_interp_sponge) then - call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& - "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& - "INTERPOLATE_SPONGE_TIME_SPACE = True.") + 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 get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & "Set True if using the newer sponging code which "//& diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 2572e15a04..26fa16d489 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -139,7 +139,7 @@ subroutine init_oda(Time, G, GV, CS) character(len=200) :: inputdir, basin_file logical :: reentrant_x, reentrant_y, tripolar_N, symmetric - if (associated(CS)) call mpp_error(FATAL,'Calling oda_init with associated control structure') + if (associated(CS)) call mpp_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) ! Use ens1 parameters , this could be changed at a later time ! if it were desirable to have alternate parameters, e.g. for the grid @@ -175,14 +175,14 @@ subroutine init_oda(Time, G, GV, CS) inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) - case('eakf') + case('eakf') CS%assim_method = EAKF_ASSIM - case('oi') - CS%assim_method = OI_ASSIM - case('no_assim') + case('oi') + CS%assim_method = OI_ASSIM + case('no_assim') CS%assim_method = NO_ASSIM - case default - call mpp_error(FATAL,'Invalid assimilation method provided') + case default + call mpp_error(FATAL, 'Invalid assimilation method provided') end select ens_info = get_ensemble_size() @@ -192,8 +192,8 @@ subroutine init_oda(Time, G, GV, CS) !! Switch to global pelist allocate(CS%ensemble_pelist(CS%ensemble_size,npes_pm)) allocate(CS%filter_pelist(CS%ensemble_size*npes_pm)) - call get_ensemble_pelist(CS%ensemble_pelist,'ocean') - call get_ensemble_filter_pelist(CS%filter_pelist,'ocean') + call get_ensemble_pelist(CS%ensemble_pelist, 'ocean') + call get_ensemble_filter_pelist(CS%filter_pelist, 'ocean') call set_current_pelist(CS%filter_pelist) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 0751177a5d..c431c16ce4 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -780,7 +780,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) - enddo ; enddo ; enddo + enddo ; enddo ; enddo endif !$OMP do do j=js-1,je+1 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index f65a7d150e..89c0bf8377 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -90,7 +90,7 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) ! Warn user if EPBL is being used, since in this case mixing due to convection will ! be aplied in the boundary layer if (useEPBL) then - call MOM_error(WARNING, 'MOM_CVMix_conv_init: '// & + call MOM_error(WARNING, 'MOM_CVMix_conv_init: '// & 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True'//& 'as convective mixing might occur in the boundary layer.') endif diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index b50f4c1c88..85d9c63a39 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -231,22 +231,22 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) if (CS%use_LMD94) then - NumberTrue=NumberTrue + 1 - CS%Mix_Scheme='KPP' + NumberTrue=NumberTrue + 1 + CS%Mix_Scheme='KPP' endif call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, & "If true, use the Pacanowski and Philander (JPO 1981) "//& "shear mixing parameterization.", default=.false.) if (CS%use_PP81) then - NumberTrue = NumberTrue + 1 - CS%Mix_Scheme='PP' + NumberTrue = NumberTrue + 1 + CS%Mix_Scheme='PP' endif use_JHL=kappa_shear_is_used(param_file) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. ! Otherwise, warn user and kill job. if ((NumberTrue) > 1) then - call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & + call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') endif diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1ff12b9099..8b72809837 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1222,7 +1222,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) - endif + endif ! ea is for passive tracers do i=is,ie ! ea(i,j,1) = netMassInOut(i) @@ -1580,7 +1580,7 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori return else allocate(CS) - endif + endif CS%diag => diag CS%Time => Time diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 7c3697550e..99dee11b9a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -304,8 +304,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if ((CS%use_CVMix_ddiff .or. CS%double_diffusion) .and. & .not.(present(Kd_extra_T) .and. present(Kd_extra_S))) & - call MOM_error(FATAL, "set_diffusivity: both Kd_extra_T and Kd_extra_S must be present "//& - "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") + call MOM_error(FATAL, "set_diffusivity: both Kd_extra_T and Kd_extra_S must be present "//& + "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index e7f7ad9d0d..b870dff1af 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -944,7 +944,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv deallocate(exp_hab_zetar) case default - call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & "#define CVMIX_TIDAL_SCHEME found in input file.") end select diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index fdf76597ef..62fe491bfc 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1762,49 +1762,49 @@ 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=US%Z2_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=US%Z2_T_to_m2_s) 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=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) + '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) + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & - 'Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Zonal Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & - 'Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Meridional Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & - 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & - 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, & - Time, 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + 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) 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) + 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_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & - Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & - Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index ce4f6308b2..650e66c47f 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -67,22 +67,22 @@ module MOM_generic_tracer !> Control structure for generic tracers type, public :: MOM_generic_tracer_CS ; private - 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. - logical :: tracers_may_reinit !< If true, tracers may go through the - !! initialization code if they are not found in the restart files. - - 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 - - !> Pointer to the first element of the linked list of generic tracers. - type(g_tracer_type), pointer :: g_tracer_list => NULL() - - integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV + 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. + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + 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 + + !> Pointer to the first element of the linked list of generic tracers. + type(g_tracer_type), pointer :: g_tracer_list => NULL() + + integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV end type MOM_generic_tracer_CS diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index a1d7d2fc9d..279f6e901c 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -356,9 +356,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Calculate pressure at interfaces and layer averaged alpha/beta if (present(p_surf)) then - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - CS%Pint(i,j,1) = p_surf(i,j) - enddo ; enddo + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%Pint(i,j,1) = p_surf(i,j) + enddo ; enddo else CS%Pint(:,:,1) = 0. endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 678199f9cb..87a8c8f9a4 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -342,7 +342,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !! tracer change [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhr !< accumulated volume/mass flux through !! the zonal face [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_neglect !< A tiny zonal mass flux that can + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_neglect !< A tiny zonal mass flux that can !! be neglected [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used logical, dimension(SZJ_(G),SZK_(GV)), intent(inout) :: domore_u !< If true, there is more advection to be @@ -443,41 +443,41 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! loop through open boundaries and recalculate flux terms 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 - if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then - I = segment%HI%IsdB - do m = 1,ntr ! replace tracers with OBC values - if (associated(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) - else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) - endif + 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 + if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then + I = segment%HI%IsdB + do m = 1,ntr ! replace tracers with OBC values + if (associated(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) else - if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - endif + T_tmp(i+1,m) = 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 + else + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + endif + endif + enddo + do m = 1,ntr ! Apply update tracer values for slope calculation + do i=segment%HI%IsdB-1,segment%HI%IsdB+1 + Tp = T_tmp(i+1,m) ; Tc = T_tmp(i,m) ; Tm = T_tmp(i-1,m) + dMx = max( Tp, Tc, Tm ) - Tc + dMn= Tc - min( Tp, Tc, Tm ) + slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * & + sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) enddo - do m = 1,ntr ! Apply update tracer values for slope calculation - do i=segment%HI%IsdB-1,segment%HI%IsdB+1 - Tp = T_tmp(i+1,m) ; Tc = T_tmp(i,m) ; Tm = T_tmp(i-1,m) - dMx = max( Tp, Tc, Tm ) - Tc - dMn= Tc - min( Tp, Tc, Tm ) - slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * & - sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) - enddo - enddo + enddo - endif - endif - enddo - endif; endif + endif + endif + enddo + endif ; endif ! Calculate the i-direction fluxes of each tracer, using as much @@ -590,7 +590,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Tracer fluxes are set to prescribed values only for inflows from masked areas. ! Now changing to simply fixed inflows. if ((uhr(I,j,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_W) .or. & - (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then + (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 @@ -614,7 +614,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Tracer fluxes are set to prescribed values only for inflows from masked areas. 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 + (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 if (associated(segment%tr_Reg%Tr(m)%tres)) then @@ -813,42 +813,42 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! loop through open boundaries and recalculate flux terms 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 - do i=is,ie - 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 - if (associated(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) - else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) - endif + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + do i=is,ie + 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 + if (associated(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) else - if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - endif + T_tmp(i,m,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 + else + T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + endif + endif + enddo + do m = 1,ntr ! Apply update tracer values for slope calculation + do j=segment%HI%JsdB-1,segment%HI%JsdB+1 + Tp = T_tmp(i,m,j+1) ; Tc = T_tmp(i,m,j) ; Tm = T_tmp(i,m,j-1) + dMx = max( Tp, Tc, Tm ) - Tc + dMn= Tc - min( Tp, Tc, Tm ) + slope_y(i,m,j) = G%mask2dCv(i,J)*G%mask2dCv(i,J-1) * & + sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) enddo - do m = 1,ntr ! Apply update tracer values for slope calculation - do j=segment%HI%JsdB-1,segment%HI%JsdB+1 - Tp = T_tmp(i,m,j+1) ; Tc = T_tmp(i,m,j) ; Tm = T_tmp(i,m,j-1) - dMx = max( Tp, Tc, Tm ) - Tc - dMn= Tc - min( Tp, Tc, Tm ) - slope_y(i,m,j) = G%mask2dCv(i,J)*G%mask2dCv(i,J-1) * & - sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) - enddo - enddo - endif - endif ! is_N_S - enddo ! i-loop - enddo ! segment loop - endif; endif + enddo + endif + endif ! is_N_S + enddo ! i-loop + enddo ! segment loop + endif ; endif ! Calculate the j-direction fluxes of each tracer, using as much ! the minimum of the remaining mass flux (vhr) and the half the mass @@ -963,7 +963,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! Tracer fluxes are set to prescribed values only for inflows from masked areas. ! Now changing to simply fixed inflows. 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 + (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then vhh(i,J) = vhr(i,J,k) do m=1,ntr if (associated(segment%tr_Reg%Tr(m)%t)) then @@ -998,7 +998,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif enddo endif - endif; endif + endif ; endif else ! not domore_v. do i=is,ie ; vhh(i,J) = 0.0 ; enddo diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 1a081f4aaf..1a240c8995 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -776,7 +776,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Sort each column by increasing density. This should already be close, ! and the size of the arrays are small, so straight insertion is used. !$OMP do - do j=js-1,je+1; do i=is-1,ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 do k=2,num_srt(i,j) ; if (rho_srt(i,k,j) < rho_srt(i,k-1,j)) then ! The last segment needs to be shuffled earlier in the list. do k2 = k,2,-1 ; if (rho_srt(i,k2,j) >= rho_srt(i,k2-1,j)) exit @@ -1530,19 +1530,19 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic CS%id_CFL = -1 CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCu1, Time, & - 'Epipycnal tracer diffusivity at zonal faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + '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, & - 'Epipycnal tracer diffusivity at meridional faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + '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, & - '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', & - cmor_long_name = 'Ocean Tracer Epineutral Laplacian Diffusivity') + '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', & + cmor_long_name = 'Ocean Tracer Epineutral Laplacian Diffusivity') CS%id_khdt_x = register_diag_field('ocean_model', 'KHDT_x', diag%axesCu1, Time, & - 'Epipycnal tracer diffusivity operator at zonal faces of tracer cell', 'm2', conversion=US%L_to_m**2) + 'Epipycnal tracer diffusivity operator at zonal faces of tracer cell', 'm2', conversion=US%L_to_m**2) CS%id_khdt_y = register_diag_field('ocean_model', 'KHDT_y', diag%axesCv1, Time, & - 'Epipycnal tracer diffusivity operator at meridional faces of tracer cell', 'm2', conversion=US%L_to_m**2) + 'Epipycnal tracer diffusivity operator at meridional faces of tracer cell', 'm2', conversion=US%L_to_m**2) if (CS%check_diffusive_CFL) then CS%id_CFL = register_diag_field('ocean_model', 'CFL_lateral_diff', diag%axesT1, Time,& 'Grid CFL number for lateral/neutral tracer diffusion', 'nondim') diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index d5f2b3963b..8380aa86b6 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -311,10 +311,10 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 - if (G%geoLonT(i,j) <= (CS%CSL)) then - CS%tr(i,j,1,m) = 1.0 !first layer - endif + ! set tracer to 1.0 in the surface of the continental shelf + if (G%geoLonT(i,j) <= (CS%CSL)) then + CS%tr(i,j,1,m) = 1.0 !first layer + endif enddo ; enddo if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index a2f1fdaa62..293d601757 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -449,7 +449,7 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC ! 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) ) + e0(k) = -G%max_depth * ( real(k-1) / real(nz) ) enddo e0(nz+1) = -G%max_depth do j=js,je ; do i=is,ie diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index f4778f0d9a..c6e8910def 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -233,7 +233,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo - enddo ; enddo + enddo ; enddo case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. @@ -536,46 +536,46 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) select case ( coordinateMode(verticalCoordinate) ) - case ( REGRIDDING_RHO ) - ! Construct notional interface positions - e0(1) = 0. - do K=2,nz - e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range - e0(k) = min( 0., e0(k) ) ! Bound by surface - e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model - ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',& - ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) - ! call MOM_mesg(mesg,5) - enddo - e0(nz+1) = -G%max_depth - - ! Calculate thicknesses - do j=js,je ; do i=is,ie - eta1D(nz+1) = -G%bathyT(i,j) - do k=nz,1,-1 - 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 - else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) - endif - enddo - enddo ; enddo - - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates - do j=js,je ; do i=is,ie - eta1D(nz+1) = -G%bathyT(i,j) - do k=nz,1,-1 - 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 - else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) - endif - enddo - enddo ; enddo + case ( REGRIDDING_RHO ) + ! Construct notional interface positions + e0(1) = 0. + do K=2,nz + e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = min( 0., e0(k) ) ! Bound by surface + e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',& + ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! call MOM_mesg(mesg,5) + enddo + e0(nz+1) = -G%max_depth + + ! Calculate thicknesses + do j=js,je ; do i=is,ie + eta1D(nz+1) = -G%bathyT(i,j) + do k=nz,1,-1 + 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 + else + h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + do j=js,je ; do i=is,ie + eta1D(nz+1) = -G%bathyT(i,j) + do k=nz,1,-1 + 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 + else + h(i,j,k) = GV%Z_to_H*(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 diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 25e60d4895..adaee16d4e 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -238,9 +238,9 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) if (CS%relative_tau) then - REL_TAU_FAC = 1. + REL_TAU_FAC = 1. else - REL_TAU_FAC = 0. !Multiplied to 0 surface current + REL_TAU_FAC = 0. !Multiplied to 0 surface current endif !> Compute storm center location @@ -432,9 +432,9 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) if ( (radius > 10.*CS%rad_max_wind) .and.& (radius < 15.*CS%rad_max_wind) ) then - ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. + ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. elseif (radius > 15.*CS%rad_max_wind) then - ALPH = 0.0 + ALPH = 0.0 endif ALPH = ALPH * CS%Deg2Rad @@ -545,12 +545,12 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! be maintained. Causes winds far from storm center to be a ! couple of m/s higher than the correct Holland prof. if (BR_Bench) then - rkm = rad/1000. - rB = (US%L_to_m*rkm)**B + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B else - ! if not comparing to benchmark, then use correct Holland prof. - rkm = rad - rB = (US%L_to_m*rad)**B + ! if not comparing to benchmark, then use correct Holland prof. + rkm = rad + rB = (US%L_to_m*rad)**B endif !/ BR ! Calculate U10 in the interior (inside of 10x radius of maximum wind), @@ -561,11 +561,11 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then rad=(CS%rad_max_wind)*10. if (BR_Bench) then - rkm = rad/1000. - rB = (US%L_to_m*rkm)**B + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B else - rkm = rad - rB = (US%L_to_m*rad)**B + rkm = rad + rB = (US%L_to_m*rad)**B endif U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & * (12. - rad/CS%rad_max_wind)/2. @@ -588,7 +588,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ALPH = 0.0 endif ALPH = ALPH * Deg2Rad - !/BR + !/BR ! Prepare for wind calculation ! X_TS is component of translation speed added to wind vector ! due to background steering wind. diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index f528323fe6..3e078b135b 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -211,9 +211,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Dummy Check if (associated(CS)) then - call MOM_error(FATAL, "wave_interface_init called with an associated"//& - "control structure.") - return + call MOM_error(FATAL, "wave_interface_init called with an associated control structure.") + return endif PI=4.0*atan(1.0) @@ -327,9 +326,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & "Y-direction surface Stokes drift for bands.",units='m/s', & default=0.0) - case default! No method provided - call MOM_error(FATAL,'Check WAVE_METHOD.') - end select + case default! No method provided + call MOM_error(FATAL,'Check WAVE_METHOD.') + end select case (DHH85_STRING)!Donelan et al., 1985 spectrum WaveMethod = DHH85 @@ -349,8 +348,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number WaveMethod = LF17 - case default - call MOM_error(FATAL,'Check WAVE_METHOD.') + case default + call MOM_error(FATAL,'Check WAVE_METHOD.') end select ! Langmuir number Options From 3f7d3cf1e2984f0e050e54e99a9fbaa9427224ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Dec 2020 13:24:00 -0500 Subject: [PATCH 067/212] Corrected additional non-standard line indents Corrected additional cases where the line indent pattern does not match the MOM6 standards, especially in some routines in MOM_open_boundary.F90, MOM_diag_mediator.F90, and MOM_ice_shelf related code. All answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 66 +- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 10 +- .../solo_driver/user_surface_forcing.F90 | 2 +- src/core/MOM_open_boundary.F90 | 2140 ++++++++--------- src/framework/MOM_diag_mediator.F90 | 1043 ++++---- src/framework/MOM_file_parser.F90 | 9 +- src/ice_shelf/MOM_ice_shelf.F90 | 82 +- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 20 +- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 40 +- 10 files changed, 1703 insertions(+), 1711 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 774201ddb5..296ed3f74c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -795,9 +795,9 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) endif call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) @@ -1065,40 +1065,40 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) + case('area') + array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) !OR same result ! do j=g_jsc,g_jec ; do i=g_isc,g_iec ! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) ! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case('s_surf') - array2D(isc:,jsc:) = Ocean%s_surf(isc:,jsc:) - case('sea_lev') - array2D(isc:,jsc:) = Ocean%sea_lev(isc:,jsc:) - case('frazil') - array2D(isc:,jsc:) = Ocean%frazil(isc:,jsc:) - case('melt_pot') - array2D(isc:,jsc:) = Ocean%melt_potential(isc:,jsc:) - case('obld') - array2D(isc:,jsc:) = Ocean%OBLD(isc:,jsc:) - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case('s_surf') + array2D(isc:,jsc:) = Ocean%s_surf(isc:,jsc:) + case('sea_lev') + array2D(isc:,jsc:) = Ocean%sea_lev(isc:,jsc:) + case('frazil') + array2D(isc:,jsc:) = Ocean%frazil(isc:,jsc:) + case('melt_pot') + array2D(isc:,jsc:) = Ocean%melt_potential(isc:,jsc:) + case('obld') + array2D(isc:,jsc:) = Ocean%OBLD(isc:,jsc:) + case default + call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) end select end subroutine ocean_model_data2D_get @@ -1215,7 +1215,7 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo case default - call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) + call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) end select end subroutine ocean_model_get_UV_surf diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index e2f0694b6c..679f147797 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -274,7 +274,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - endif + endif end subroutine MESO_surface_forcing_init diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 3d8b398516..6ace2e05c2 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1240,7 +1240,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! note the sign convention do j=js,je ; do i=is,ie - fluxes%sens(i,j) = -US%W_m2_to_QRZ_T * fluxes%sens(i,j) ! Normal convention is positive into the ocean + fluxes%sens(i,j) = -US%W_m2_to_QRZ_T * fluxes%sens(i,j) ! Normal convention is positive into the ocean ! but sensible is normally a positive quantity in the files enddo ; enddo @@ -1271,11 +1271,11 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! Read the SST and SSS fields for damping. if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then - call data_override('OCN', 'SST_restore', CS%T_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + call data_override('OCN', 'SST_restore', CS%T_restore(:,:), day, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - call data_override('OCN', 'SSS_restore', CS%S_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + call data_override('OCN', 'SSS_restore', CS%S_restore(:,:), day, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) endif diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index f5372e07d2..d8f008e9ef 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -89,7 +89,7 @@ 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%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * (US%L_to_Z/CS%Rho0)) enddo ; enddo ; endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 1a4433f034..25a76591b2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1341,10 +1341,10 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile if (Ie_obc>Is_obc) then - OBC%segment(l_seg)%direction = OBC_DIRECTION_S + OBC%segment(l_seg)%direction = OBC_DIRECTION_S elseif (Ie_obc Parse an OBC_SEGMENT_%%%_PARAMS string - subroutine parse_segment_param_real(segment_str, var, param_value, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed - real, intent(out) :: param_value !< The value of the parameter - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - - nfields=0 - continue=.true. - dbg=.false. - if (PRESENT(debug)) dbg=debug - - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields=nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo - - ! if (PRESENT(fields)) then - ! do n=1,nfields - ! fields(n) = flds(n) - ! enddo - ! endif - - ! if (PRESENT(num_fields)) then - ! num_fields=nfields - ! return - ! endif - - m=0 -! if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m=n - exit - endif - enddo - if (m==0) then - call abort() - endif +subroutine parse_segment_param_real(segment_str, var, param_value, debug ) + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + real, intent(out) :: param_value !< The value of the parameter + logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages + ! Local variables + character(len=128) :: word1, word2, word3, method + integer :: lword, nfields, n, m + logical :: continue,dbg + character(len=32), dimension(MAX_OBC_FIELDS) :: flds + + nfields = 0 + continue = .true. + dbg = .false. + if (PRESENT(debug)) dbg = debug + + do while (continue) + word1 = extract_word(segment_str,',',nfields+1) + if (trim(word1) == '') exit + nfields = nfields+1 + word2 = extract_word(word1,'=',1) + flds(nfields) = trim(word2) + enddo + + ! if (PRESENT(fields)) then + ! do n=1,nfields + ! fields(n) = flds(n) + ! enddo + ! endif + + ! if (PRESENT(num_fields)) then + ! num_fields = nfields + ! return + ! endif + + m=0 +! if (PRESENT(var)) then + do n=1,nfields + if (trim(var)==trim(flds(n))) then + m = n + exit + endif + enddo + if (m==0) then + call abort() + endif ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) + word3 = extract_word(segment_str,',',m) ! word1 = extract_word(word3,':',1) ! if (trim(word1) == '') exit - word2 = extract_word(word1,'=',1) - if (trim(word2) == trim(var)) then - method=trim(extract_word(word1,'=',2)) - lword=len_trim(method) - read(method(1:lword),*,err=987) param_value - ! if (method(lword-3:lword) == 'file') then - ! ! raise an error id filename/fieldname not in argument list - ! word1 = extract_word(word3,':',2) - ! filenam = extract_word(word1,'(',1) - ! fieldnam = extract_word(word1,'(',2) - ! lword=len_trim(fieldnam) - ! fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - ! value=-999. - ! elseif (method(lword-4:lword) == 'value') then - ! filenam = 'none' - ! fieldnam = 'none' - ! word1 = extract_word(word3,':',2) - ! lword=len_trim(word1) - ! read(word1(1:lword),*,end=986,err=987) value - ! endif - endif -! endif + word2 = extract_word(word1,'=',1) + if (trim(word2) == trim(var)) then + method=trim(extract_word(word1,'=',2)) + lword=len_trim(method) + read(method(1:lword),*,err=987) param_value + ! if (method(lword-3:lword) == 'file') then + ! ! raise an error id filename/fieldname not in argument list + ! word1 = extract_word(word3,':',2) + ! filenam = extract_word(word1,'(',1) + ! fieldnam = extract_word(word1,'(',2) + ! lword=len_trim(fieldnam) + ! fieldnam = fieldnam(1:lword-1) ! remove trailing parenth + ! value=-999. + ! elseif (method(lword-4:lword) == 'value') then + ! filenam = 'none' + ! fieldnam = 'none' + ! word1 = extract_word(word3,':',2) + ! lword=len_trim(word1) + ! read(word1(1:lword),*,end=986,err=987) value + ! endif + endif +! endif - return - 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) - 987 call MOM_error(FATAL,'Error while parsing segment parameter specification! '//trim(segment_str)) + return + 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) + 987 call MOM_error(FATAL,'Error while parsing segment parameter specification! '//trim(segment_str)) - end subroutine parse_segment_param_real +end subroutine parse_segment_param_real !> Initialize open boundary control structure and do any necessary rescaling of OBC !! fields that have been read from a restart file. @@ -1863,7 +1863,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) OBC%cff_normal(I,J,k) = vel2_rescale * OBC%cff_normal(I,J,k) enddo ; enddo ; enddo endif - endif + endif end subroutine open_boundary_init @@ -2237,986 +2237,986 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments - segment=>OBC%segment(n) - if (.not. segment%on_pe) cycle - if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) - if (segment%direction == OBC_DIRECTION_E) then - I=segment%HI%IsdB - if (I 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new - else - rx_avg = rx_new - endif - segment%rx_norm_rad(I,j,k) = rx_avg - ! The new boundary value is interpolated between future interior - ! value, u_new(I-1) and past boundary value but with barotropic - ! accelerations, u_new(I). - segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - if (gamma_u < 1.0) then - OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) - endif - elseif (segment%oblique) then - dhdt = (u_old(I-1,j,k) - u_new(I-1,j,k)) !old-new - dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(dhdt*dhdx, cff_new*rx_max) - ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new - else - rx_avg = rx_new - ry_avg = ry_new - cff_avg = cff_new - endif - segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg - segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & - (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & - min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & - (cff_avg + rx_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary - ! implementation as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) - endif - elseif (segment%gradient) then - segment%normal_vel(I,j,k) = u_new(I-1,j,k) - endif - if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - ! dhdt gets set to 0 on inflow in oblique case - if (dhdt*dhdx <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & - gamma_2 * segment%nudged_normal_vel(I,j,k) - endif - enddo ; enddo - if (segment%radiation_tan .or. segment%radiation_grad) then - I=segment%HI%IsdB - allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) - rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) - enddo - else - do J=segment%HI%JsdB,segment%HI%JedB - dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new - dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 - rx_tang_rad(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed - enddo - endif - enddo - if (segment%radiation_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tang_rad(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%radiation_grad) then - Js_obc = max(segment%HI%JsdB,G%jsd+1) - Je_obc = min(segment%HI%JedB,G%jed-1) - do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tang_rad(I,J,k) -! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) -! elseif (G%mask2dCu(I-1,j) > 0.0) then -! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) -! elseif (G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) -! else -! rx_avg = 0.0 -! endif - segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & - rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_rad) - endif - if (segment%oblique_tan .or. segment%oblique_grad) then - I=segment%HI%IsdB - allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) - rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) - ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) - ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) - cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) - cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) - ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) - enddo - else - do J=segment%HI%JsdB,segment%HI%JedB - dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new - dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then - dhdy = segment%grad_tan(j,1,k) - elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_tan(j+1,1,k) - endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(dhdt*dhdx, cff_new*rx_max) - ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new - enddo - endif - enddo - if (segment%oblique_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & - (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & - min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & - (cff_avg + rx_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%oblique_grad) then - Js_obc = max(segment%HI%JsdB,G%jsd+1) - Je_obc = min(segment%HI%JedB,G%jed-1) - do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_grad(I,J,k) = & - ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & - rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) - & - (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & - min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k)) ) / & - (cff_avg + rx_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_obl) - deallocate(ry_tang_obl) - deallocate(cff_tangential) - endif - endif - - if (segment%direction == OBC_DIRECTION_W) then - I=segment%HI%IsdB - if (I>G%HI%IecB) cycle - do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed - if (segment%radiation) then - dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new - dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 - rx_new = 0.0 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new - else - rx_avg = rx_new - endif - segment%rx_norm_rad(I,j,k) = rx_avg - ! The new boundary value is interpolated between future interior - ! value, u_new(I+1) and past boundary value but with barotropic - ! accelerations, u_new(I). - segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) - endif - elseif (segment%oblique) then - dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new - dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(dhdt*dhdx, cff_new*rx_max) - ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new - else - rx_avg = rx_new - ry_avg = ry_new - cff_avg = cff_new - endif - segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg - segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & - (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & - min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & - (cff_avg + rx_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) - endif - elseif (segment%gradient) then - segment%normal_vel(I,j,k) = u_new(I+1,j,k) - endif - if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - ! dhdt gets set to 0. on inflow in oblique case - if (dhdt*dhdx <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & - gamma_2 * segment%nudged_normal_vel(I,j,k) - endif - enddo ; enddo - if (segment%radiation_tan .or. segment%radiation_grad) then - I=segment%HI%IsdB - allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) - rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) - enddo - else - do J=segment%HI%JsdB,segment%HI%JedB - dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new - dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 - rx_tang_rad(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed - enddo - endif - enddo - if (segment%radiation_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tang_rad(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%radiation_grad) then - Js_obc = max(segment%HI%JsdB,G%jsd+1) - Je_obc = min(segment%HI%JedB,G%jed-1) - do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tang_rad(I,J,k) -! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) -! elseif (G%mask2dCu(I+1,j) > 0.0) then -! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) -! elseif (G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) -! else -! rx_avg = 0.0 -! endif - segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & - rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_rad) - endif - if (segment%oblique_tan .or. segment%oblique_grad) then - I=segment%HI%IsdB - allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) - rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) - ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) - ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) - cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) - cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) - ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) - enddo - else - do J=segment%HI%JsdB,segment%HI%JedB - dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new - dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then - dhdy = segment%grad_tan(j,1,k) - elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_tan(j+1,1,k) - endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(dhdt*dhdx, cff_new*rx_max) - ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new - enddo - endif - enddo - if (segment%oblique_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & - (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & - min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & - (cff_avg + rx_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%oblique_grad) then - Js_obc = max(segment%HI%JsdB,G%jsd+1) - Je_obc = min(segment%HI%JedB,G%jed-1) - do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_grad(I,J,k) = & - ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & - rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) - & - (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & - min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & - (cff_avg + rx_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (rx_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_obl) - deallocate(ry_tang_obl) - deallocate(cff_tangential) - endif - endif - - if (segment%direction == OBC_DIRECTION_N) then - J=segment%HI%JsdB - if (J 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new - else - ry_avg = ry_new - endif - segment%ry_norm_rad(i,J,k) = ry_avg - ! The new boundary value is interpolated between future interior - ! value, v_new(J-1) and past boundary value but with barotropic - ! accelerations, v_new(J). - segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) - endif - elseif (segment%oblique) then - dhdt = (v_old(i,J-1,k) - v_new(i,J-1,k)) !old-new - dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sasha for J-1 - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(dhdt*dhdy, cff_new*ry_max) - rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new - else - rx_avg = rx_new - ry_avg = ry_new - cff_avg = cff_new - endif - segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg - segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & - (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& - min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & - (cff_avg + ry_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) - endif - elseif (segment%gradient) then - segment%normal_vel(i,J,k) = v_new(i,J-1,k) - endif - if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - ! dhdt gets set to 0 on inflow in oblique case - if (dhdt*dhdy <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & - gamma_2 * segment%nudged_normal_vel(i,J,k) - endif - enddo ; enddo - if (segment%radiation_tan .or. segment%radiation_grad) then - J=segment%HI%JsdB - allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) - ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) - enddo - else - do I=segment%HI%IsdB,segment%HI%IedB - dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new - dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 - ry_tang_rad(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed - enddo - endif - enddo - if (segment%radiation_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tang_rad(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%radiation_grad) then - Is_obc = max(segment%HI%IsdB,G%isd+1) - Ie_obc = min(segment%HI%IedB,G%ied-1) - do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tang_rad(I,J,k) -! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) -! elseif (G%mask2dCv(i,J-1) > 0.0) then -! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) -! elseif (G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) -! else -! ry_avg = 0.0 -! endif - segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & - ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+ry_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(ry_tang_rad) - endif - if (segment%oblique_tan .or. segment%oblique_grad) then - J=segment%HI%JsdB - allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) - rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) - ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) - ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) - cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) - cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) - ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) - enddo - else - do I=segment%HI%IsdB,segment%HI%IedB - dhdt = u_old(I,j,k)-u_new(I,j,k) !old-new - dhdy = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then - dhdx = segment%grad_tan(i,1,k) - elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_tan(i+1,1,k) - endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(dhdt*dhdy, cff_new*ry_max) - rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new - enddo - endif - enddo - if (segment%oblique_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & - (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & - min(rx_avg,0.0)*segment%grad_tan(i+1,2,k))) / & - (cff_avg + ry_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%oblique_grad) then - Is_obc = max(segment%HI%IsdB,G%isd+1) - Ie_obc = min(segment%HI%IedB,G%ied-1) - do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_grad(I,J,k) = & - ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & - ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & - (max(rx_avg,0.0)*segment%grad_gradient(I,2,k) + & - min(rx_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & - (cff_avg + ry_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_obl) - deallocate(ry_tang_obl) - deallocate(cff_tangential) - endif - endif - - if (segment%direction == OBC_DIRECTION_S) then - J=segment%HI%JsdB - if (J>G%HI%JecB) cycle - do k=1,nz ; do i=segment%HI%isd,segment%HI%ied - if (segment%radiation) then - dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new - dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 - ry_new = 0.0 - if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new - else - ry_avg = ry_new - endif - segment%ry_norm_rad(i,J,k) = ry_avg - ! The new boundary value is interpolated between future interior - ! value, v_new(J+1) and past boundary value but with barotropic - ! accelerations, v_new(J). - segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) - endif - elseif (segment%oblique) then - dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new - dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(dhdt*dhdy, cff_new*ry_max) - rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new - else - rx_avg = rx_new - ry_avg = ry_new - cff_avg = cff_new - endif - segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg - segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & - (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & - min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & - (cff_avg + ry_avg) - if (gamma_u < 1.0) then - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) - endif - elseif (segment%gradient) then - segment%normal_vel(i,J,k) = v_new(i,J+1,k) - endif - if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - ! dhdt gets set to 0 on inflow in oblique case - if (dhdt*dhdy <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & - gamma_2 * segment%nudged_normal_vel(i,J,k) - endif - enddo ; enddo - if (segment%radiation_tan .or. segment%radiation_grad) then - J=segment%HI%JsdB - allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) - ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) - enddo - else - do I=segment%HI%IsdB,segment%HI%IedB - dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new - dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 - ry_tang_rad(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed - enddo - endif - enddo - if (segment%radiation_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tang_rad(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%radiation_grad) then - Is_obc = max(segment%HI%IsdB,G%isd+1) - Ie_obc = min(segment%HI%IedB,G%ied-1) - do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tang_rad(I,J,k) -! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) -! elseif (G%mask2dCv(i,J+1) > 0.0) then -! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) -! elseif (G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) -! else -! ry_avg = 0.0 -! endif - segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & - ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+ry_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_rad(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(ry_tang_rad) - endif - if (segment%oblique_tan .or. segment%oblique_grad) then - J=segment%HI%JsdB - allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - do k=1,nz - if (gamma_u < 1.0) then - rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) - rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) - ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) - ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) - cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) - cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) - ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) - enddo - else - do I=segment%HI%IsdB,segment%HI%IedB - dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new - dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then - dhdx = segment%grad_tan(i,1,k) - elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_tan(i+1,1,k) - endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(dhdt*dhdy, cff_new*ry_max) - rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new - enddo - endif - enddo - if (segment%oblique_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & - (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & - min(rx_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / & - (cff_avg + ry_avg) - enddo ; enddo - endif - if (segment%nudged_tan) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & - gamma_2 * segment%nudged_tangential_vel(I,J,k) - enddo ; enddo - endif - if (segment%oblique_grad) then - Is_obc = max(segment%HI%IsdB,G%isd+1) - Ie_obc = min(segment%HI%IedB,G%ied-1) - do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tang_obl(I,J,k) - ry_avg = ry_tang_obl(I,J,k) - cff_avg = cff_tangential(I,J,k) - segment%tangential_grad(I,J,k) = & - ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & - ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & - (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + & - min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & - (cff_avg + ry_avg) - enddo ; enddo - endif - if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - ! dhdt gets set to 0 on inflow in oblique case - if (ry_tang_obl(I,J,k) <= 0.0) then - tau = segment%Velocity_nudging_timescale_in - else - tau = segment%Velocity_nudging_timescale_out - endif - gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & - gamma_2 * segment%nudged_tangential_grad(I,J,k) - enddo ; enddo - endif - deallocate(rx_tang_obl) - deallocate(ry_tang_obl) - deallocate(cff_tangential) - endif - endif + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%IsdB + if (I 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif + segment%rx_norm_rad(I,j,k) = rx_avg + ! The new boundary value is interpolated between future interior + ! value, u_new(I-1) and past boundary value but with barotropic + ! accelerations, u_new(I). + segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + if (gamma_u < 1.0) then + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + endif + elseif (segment%oblique) then + dhdt = (u_old(I-1,j,k) - u_new(I-1,j,k)) !old-new + dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary + ! implementation as a work-around to limitations in restart capability + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + endif + elseif (segment%gradient) then + segment%normal_vel(I,j,k) = u_new(I-1,j,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tang_rad(I,J,k) +! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j) > 0.0) then +! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k)) ) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + if (I>G%HI%IecB) cycle + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%radiation) then + dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new + dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 + rx_new = 0.0 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif + segment%rx_norm_rad(I,j,k) = rx_avg + ! The new boundary value is interpolated between future interior + ! value, u_new(I+1) and past boundary value but with barotropic + ! accelerations, u_new(I). + segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + endif + elseif (segment%oblique) then + dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new + dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + endif + elseif (segment%gradient) then + segment%normal_vel(I,j,k) = u_new(I+1,j,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0. on inflow in oblique case + if (dhdt*dhdx <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tang_rad(I,J,k) +! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j) > 0.0) then +! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + if (J 0.0) ry_new = min( (dhdt/dhdy), ry_max) + if (gamma_u < 1.0) then + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new + else + ry_avg = ry_new + endif + segment%ry_norm_rad(i,J,k) = ry_avg + ! The new boundary value is interpolated between future interior + ! value, v_new(J-1) and past boundary value but with barotropic + ! accelerations, v_new(J). + segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + endif + elseif (segment%oblique) then + dhdt = (v_old(i,J-1,k) - v_new(i,J-1,k)) !old-new + dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sasha for J-1 + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + endif + elseif (segment%gradient) then + segment%normal_vel(i,J,k) = v_new(i,J-1,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new + dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ry_avg = ry_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + ry_avg = ry_tang_rad(I,J,k) +! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then +! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) +! elseif (G%mask2dCv(i,J-1) > 0.0) then +! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) +! elseif (G%mask2dCv(i+1,J-1) > 0.0) then +! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) +! else +! ry_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(ry_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j,k)-u_new(I,j,k) !old-new + dhdy = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdx = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(I,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_S) then + J=segment%HI%JsdB + if (J>G%HI%JecB) cycle + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%radiation) then + dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new + dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 + ry_new = 0.0 + if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) + if (gamma_u < 1.0) then + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new + else + ry_avg = ry_new + endif + segment%ry_norm_rad(i,J,k) = ry_avg + ! The new boundary value is interpolated between future interior + ! value, v_new(J+1) and past boundary value but with barotropic + ! accelerations, v_new(J). + segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + endif + elseif (segment%oblique) then + dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new + dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + endif + elseif (segment%gradient) then + segment%normal_vel(i,J,k) = v_new(i,J+1,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ry_avg = ry_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + ry_avg = ry_tang_rad(I,J,k) +! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then +! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i,J+1) > 0.0) then +! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i+1,J+1) > 0.0) then +! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) +! else +! ry_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(ry_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdx = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif enddo ! Actually update u_new, v_new @@ -3492,12 +3492,12 @@ function lookup_seg_field(OBC_seg,field) ! Local variables integer :: n - lookup_seg_field=-1 + lookup_seg_field = -1 do n=1,OBC_seg%num_fields - if (trim(field) == OBC_seg%field(n)%name) then - lookup_seg_field=n - return - endif + if (trim(field) == OBC_seg%field(n)%name) then + lookup_seg_field = n + return + endif enddo end function lookup_seg_field @@ -5168,12 +5168,12 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) nz = size(segment%field(fld)%dz_src,3) if (segment%is_E_or_W) then - ! segment thicknesses are defined at cell face centers. - is = segment%HI%isdB ; ie = segment%HI%iedB - js = segment%HI%jsd ; je = segment%HI%jed + ! segment thicknesses are defined at cell face centers. + is = segment%HI%isdB ; ie = segment%HI%iedB + js = segment%HI%jsd ; je = segment%HI%jed else - is = segment%HI%isd ; ie = segment%HI%ied - js = segment%HI%jsdB ; je = segment%HI%jedB + is = segment%HI%isd ; ie = segment%HI%ied + js = segment%HI%jsdB ; je = segment%HI%jedB endif allocate(eta(is:ie,js:je,nz+1)) contractions=0; dilations=0 @@ -5318,8 +5318,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! remap_CS is set up by initialize_segment_data, so we copy the fields here. if (ASSOCIATED(OBC_in%remap_CS)) then - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index f0f2d942e6..5c7106a7ae 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -73,23 +73,23 @@ module MOM_diag_mediator !> Down sample a field interface downsample_field - module procedure downsample_field_2d, downsample_field_3d + module procedure downsample_field_2d, downsample_field_3d end interface downsample_field !> Down sample the mask of a field interface downsample_mask - module procedure downsample_mask_2d, downsample_mask_3d + module procedure downsample_mask_2d, downsample_mask_3d end interface downsample_mask !> Down sample a diagnostic field interface downsample_diag_field - module procedure downsample_diag_field_2d, downsample_diag_field_3d + module procedure downsample_diag_field_2d, downsample_diag_field_3d end interface downsample_diag_field !> 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 + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes end type diag_dsamp !> A group of 1D axes that comprise a 1D/2D/3D mesh @@ -367,62 +367,61 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) if (diag_cs%grid_space_axes) then - allocate(IaxB(G%IsgB:G%IegB)) - do i=G%IsgB, G%IegB - Iaxb(i)=real(i) - enddo - allocate(iax(G%isg:G%ieg)) - do i=G%isg, G%ieg - iax(i)=real(i)-0.5 - enddo - allocate(JaxB(G%JsgB:G%JegB)) - do j=G%JsgB, G%JegB - JaxB(j)=real(j) - enddo - allocate(jax(G%jsg:G%jeg)) - do j=G%jsg, G%jeg - jax(j)=real(j)-0.5 - enddo + allocate(IaxB(G%IsgB:G%IegB)) + do i=G%IsgB, G%IegB + Iaxb(i)=real(i) + enddo + allocate(iax(G%isg:G%ieg)) + do i=G%isg, G%ieg + iax(i)=real(i)-0.5 + enddo + allocate(JaxB(G%JsgB:G%JegB)) + do j=G%JsgB, G%JegB + JaxB(j)=real(j) + enddo + allocate(jax(G%jsg:G%jeg)) + do j=G%jsg, G%jeg + jax(j)=real(j)-0.5 + enddo endif ! Horizontal axes for the native grids if (G%symmetric) then - if (diag_cs%grid_space_axes) then - id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & - 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & - 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) - else - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) - endif + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif else - if (diag_cs%grid_space_axes) then - id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & - 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & - 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) - else - id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) - endif + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif endif - 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & - 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'h point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) else - id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain) endif if (set_vert) then @@ -578,7 +577,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) enddo if (diag_cs%grid_space_axes) then - deallocate(IaxB,iax,JaxB,jax) + deallocate(IaxB, iax, JaxB, jax) endif !Define the downsampled axes call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) @@ -606,153 +605,153 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n id_zl = id_zl_native ; id_zi = id_zi_native !Axes group for native downsampled diagnostics do dl=2,MAX_DSAMP_LEV - if (dl /= 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") - if (G%symmetric) then - allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) - allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) - do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo - do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo - id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - deallocate(gridLonB_dsamp,gridLatB_dsamp) - else - allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) - allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo - do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo - id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - deallocate(gridLonB_dsamp,gridLatB_dsamp) - endif - - allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) - allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo - do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo - id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & + if (dl /= 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + if (G%symmetric) then + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + else + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + endif + + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo + id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & + id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - deallocate(gridLonT_dsamp,gridLatT_dsamp) - - ! Axis groupings for the model layers - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & - x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & - is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & - x_cell_method='point', y_cell_method='point', v_cell_method='mean', & - is_q_point=.true., is_layer=.true.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & - x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & - is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & - x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & - is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - - ! Axis groupings for the model interfaces - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & - x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & - is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & - x_cell_method='point', y_cell_method='point', v_cell_method='point', & - is_q_point=.true., is_interface=.true.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & - x_cell_method='point', y_cell_method='mean', v_cell_method='point', & - is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & - x_cell_method='mean', y_cell_method='point', v_cell_method='point', & - is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - - ! Axis groupings for 2-D arrays - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & - x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & - x_cell_method='point', y_cell_method='point', is_q_point=.true.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & - x_cell_method='point', y_cell_method='mean', is_u_point=.true.) - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & - x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - - !Non-native axes - if (diag_cs%num_diag_coords>0) then - allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) - allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) - endif - - do i=1, diag_cs%num_diag_coords - ! For each possible diagnostic coordinate - !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) - - ! This vertical coordinate has been configured so can be used. - if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then - - ! This fetches the 1D-axis id for layers and interfaces and overwrite - ! id_zl and id_zi from above. It also returns the number of layers. - call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) - - ! Axes for z layers - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & + deallocate(gridLonT_dsamp,gridLatT_dsamp) + + ! Axis groupings for the model layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + !Non-native axes + if (diag_cs%num_diag_coords>0) then + allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - !! \note Remapping for B points is not yet implemented so needs_remapping is not - !! provided for remap_axesBL - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='mean', & is_q_point=.true., is_layer=.true., is_native=.false.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - ! Axes for z interfaces - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & + ! Axes for z interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & xyave_axes=diag_cs%remap_axesZi(i)) - !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='point', & is_q_point=.true., is_interface=.true., is_native=.false.) - call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='mean', v_cell_method='point', & is_u_point=.true., is_interface=.true., is_native=.false., & needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) - call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='point', v_cell_method='point', & is_v_point=.true., is_interface=.true., is_native=.false., & needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) - endif - enddo + endif + enddo enddo end subroutine set_axes_info_dsamp @@ -871,49 +870,49 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) !The downsampled mask is needed for sending out the diagnostics output via diag_manager !The non-downsampled mask is needed for downsampling the diagnostics field do dl=2,MAX_DSAMP_LEV - if (dl /= 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") - 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, & - 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) - 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) - 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) - 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, & - 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) - 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) - 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) - diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask - enddo + if (dl /= 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") + 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, & + 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) + 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) + 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) + 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, & + 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) + 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) + 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) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask + enddo enddo end subroutine set_masks_for_axes_dsamp @@ -1937,10 +1936,10 @@ end function get_diag_time_end !> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics !! derived from one field. integer function register_diag_field(module_name, field_name, axes_in, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & - x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field @@ -2221,10 +2220,10 @@ end function register_diag_field !> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & - x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field @@ -2364,8 +2363,8 @@ end function register_diag_field_expand_cmor !> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes !! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures. integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count) character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field @@ -2519,36 +2518,36 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho mstr = diag%axes%v_cell_method if (present(v_extensive)) then - if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & - 'Vertical cell method was specified along with the vertically extensive flag.') - if (v_extensive) then - mstr='sum' - else - mstr='mean' - endif + if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if (v_extensive) then + mstr='sum' + else + mstr='mean' + endif elseif (present(v_cell_method)) then - mstr = v_cell_method + mstr = v_cell_method endif if (trim(mstr)=='sum') then - xyz_method = xyz_method + 1 + xyz_method = xyz_method + 1 elseif (trim(mstr)=='mean') then - xyz_method = xyz_method + 2 + xyz_method = xyz_method + 2 endif mstr = diag%axes%y_cell_method if (present(y_cell_method)) mstr = y_cell_method if (trim(mstr)=='sum') then - xyz_method = xyz_method + 10 + xyz_method = xyz_method + 10 elseif (trim(mstr)=='mean') then - xyz_method = xyz_method + 20 + xyz_method = xyz_method + 20 endif mstr = diag%axes%x_cell_method if (present(x_cell_method)) mstr = x_cell_method if (trim(mstr)=='sum') then - xyz_method = xyz_method + 100 + xyz_method = xyz_method + 100 elseif (trim(mstr)=='mean') then - xyz_method = xyz_method + 200 + xyz_method = xyz_method + 200 endif diag%xyz_method = xyz_method @@ -2641,15 +2640,15 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method) endif elseif (present(v_extensive)) then - if (v_extensive) then - if (axes%rank==1) then - call get_diag_axis_name(axes%handles(1), axis_name) - elseif (axes%rank==3) then - call get_diag_axis_name(axes%handles(3), axis_name) + if (v_extensive) then + if (axes%rank==1) then + call get_diag_axis_name(axes%handles(1), axis_name) + elseif (axes%rank==3) then + call get_diag_axis_name(axes%handles(3), axis_name) + endif + call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' endif - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') - ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' - endif else if (len(trim(axes%v_cell_method))>0) then if (axes%rank==1) then @@ -2673,9 +2672,9 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & end subroutine attach_cell_methods function register_scalar_field(module_name, field_name, init_time, diag_cs, & - long_name, units, missing_value, range, standard_name, & - do_not_log, err_msg, interp_method, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name) + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name) integer :: register_scalar_field !< An integer handle for a diagnostic array. character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" @@ -2777,10 +2776,10 @@ end function register_scalar_field !> Registers a static diagnostic, returning an integer handle function register_static_field(module_name, field_name, axes, & - long_name, units, missing_value, range, mask_variant, standard_name, & - do_not_log, interp_method, tile_count, & - cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & - x_cell_method, y_cell_method, area_cell_method, conversion) + long_name, units, missing_value, range, mask_variant, standard_name, & + do_not_log, interp_method, tile_count, & + cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & + x_cell_method, y_cell_method, area_cell_method, conversion) integer :: register_static_field !< An integer handle for a diagnostic array. character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" @@ -3301,8 +3300,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_begin(id_clock_diag_grid_updates) if (diag_cs%diag_grid_overridden) then - call MOM_error(FATAL, "diag_update_remap_grids was called, but current grids in "// & - "diagnostic structure have been overridden") + call MOM_error(FATAL, "diag_update_remap_grids was called, but current grids in "// & + "diagnostic structure have been overridden") endif if (update_intensive_local) then @@ -3418,18 +3417,18 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) do i=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(i)%mask2dT) - deallocate(diag_cs%dsamp(i)%mask2dBu) - deallocate(diag_cs%dsamp(i)%mask2dCu) - deallocate(diag_cs%dsamp(i)%mask2dCv) - deallocate(diag_cs%dsamp(i)%mask3dTL) - deallocate(diag_cs%dsamp(i)%mask3dBL) - deallocate(diag_cs%dsamp(i)%mask3dCuL) - deallocate(diag_cs%dsamp(i)%mask3dCvL) - deallocate(diag_cs%dsamp(i)%mask3dTi) - deallocate(diag_cs%dsamp(i)%mask3dBi) - deallocate(diag_cs%dsamp(i)%mask3dCui) - deallocate(diag_cs%dsamp(i)%mask3dCvi) + deallocate(diag_cs%dsamp(i)%mask2dT) + deallocate(diag_cs%dsamp(i)%mask2dBu) + deallocate(diag_cs%dsamp(i)%mask2dCu) + deallocate(diag_cs%dsamp(i)%mask2dCv) + deallocate(diag_cs%dsamp(i)%mask3dTL) + deallocate(diag_cs%dsamp(i)%mask3dBL) + deallocate(diag_cs%dsamp(i)%mask3dCuL) + deallocate(diag_cs%dsamp(i)%mask3dCvL) + deallocate(diag_cs%dsamp(i)%mask3dTi) + deallocate(diag_cs%dsamp(i)%mask3dBi) + deallocate(diag_cs%dsamp(i)%mask3dCui) + deallocate(diag_cs%dsamp(i)%mask3dCvi) enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) @@ -3718,37 +3717,37 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) ! coarse d extents 1 28 1 28 do dl=2,MAX_DSAMP_LEV - ! 2d mask - call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & - 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, & - 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. - allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) - do k=1,nz - diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) - diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) - diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) - diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) - enddo - allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) - do k=1,nz+1 - diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) - diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) - diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) - diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) - enddo + ! 2d mask + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + 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, & + 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. + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) + do k=1,nz + diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + do k=1,nz+1 + diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo enddo end subroutine downsample_diag_masks_set @@ -3775,13 +3774,13 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. if (first_check) then - if (mod(diag_cs%ie-diag_cs%is+1, dl) /= 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) /= 0) then - write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& + if (mod(diag_cs%ie-diag_cs%is+1, dl) /= 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) /= 0) then + write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je - call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) - endif - first_check = .false. + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + first_check = .false. endif cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 @@ -3792,35 +3791,35 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev f2 = fo2/dl !Correction for the symmetric case if (diag_cs%G%symmetric) then - f1 = f1 + mod(fo1,dl) - f2 = f2 + mod(fo2,dl) + f1 = f1 + mod(fo1,dl) + f2 = f2 + mod(fo2,dl) endif if ( f1 == dszi ) then - isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies !The rest is not taken with the full MOM6 diag_table elseif ( f1 == dszi + 1 ) then - isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain elseif ( f1 == cszi) then - isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain elseif ( f1 == cszi + 1 ) then - isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain else - write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + write (mesg,*) " peculiar size ",f1," in i-direction\n"//& "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif if ( f2 == dszj ) then - jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain elseif ( f2 == dszj + 1 ) then - jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain elseif ( f2 == cszj) then - jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain elseif ( f2 == cszj + 1 ) then - jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain else - write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + write (mesg,*) " peculiar size ",f2," in j-direction\n"//& "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif end subroutine downsample_diag_indices_get @@ -3845,23 +3844,23 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field - f1 = size(locfield,1) - f2 = size(locfield,2) + f1 = size(locfield, 1) + f2 = size(locfield, 2) !Save the extents of the original (fine) domain isv_o = isv ; jsv_o = jsv !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them - call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev) !Set the non-downsampled mask, it must be associated and initialized if (present(mask)) then - locmask => mask + locmask => mask elseif (associated(diag%axes%mask3d)) then - locmask => diag%axes%mask3d + locmask => diag%axes%mask3d else - call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") + call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") endif call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & - isv_o,jsv_o,isv,iev,jsv,jev) + isv_o, jsv_o, isv, iev, jsv, jev) end subroutine downsample_diag_field_3d @@ -3980,117 +3979,117 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d f2 = f_in2/dl !Correction for the symmetric case if (diag_cs%G%symmetric) then - f1 = f1 + mod(f_in1,dl) - f2 = f2 + mod(f_in2,dl) + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) endif allocate(field_out(1:f1,1:f2,ks:ke)) ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain if (method == MMM) then - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! - weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj,k) * weight - enddo ; enddo - field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo ; enddo - elseif (method == SSS) then !e.g., volcello - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight - enddo ; enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) - enddo ; enddo ; enddo - elseif (method == MMP .or. method == MMS) then !e.g., T_advection_xy - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj,k)*weight - enddo ; enddo - field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo ; enddo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k) * weight + enddo ; enddo + field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo + elseif (method == SSS) then !e.g., volcello + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo ; enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo + elseif (method == MMP .or. method == MMS) then !e.g., T_advection_xy + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k)*weight + enddo ; enddo + field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo elseif (method == PMM) then - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) - total_weight = total_weight +weight - ave = ave+field_in(ii,jj,k)*weight - enddo - field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo ; enddo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo elseif (method == PSS) then !e.g. umo - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight - enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) - enddo ; enddo ; enddo - elseif (method == SPS) then !e.g. vmo - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight - enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) - enddo ; enddo ; enddo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo + elseif (method == SPS) then !e.g. vmo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo elseif (method == MPM) then - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj,k)*weight - enddo - field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo ; enddo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo elseif (method == MSK) then !The input field is a mask, subsample - field_out(:,:,:) = 0.0 - do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - ave = ave+field_in(ii,jj,k) - enddo ; enddo - if (ave > 0.0) field_out(i,j,k)=1.0 - enddo ; enddo ; enddo + field_out(:,:,:) = 0.0 + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave = ave+field_in(ii,jj,k) + enddo ; enddo + if (ave > 0.0) field_out(i,j,k)=1.0 + enddo ; enddo ; enddo else - write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) endif end subroutine downsample_field_3d @@ -4134,109 +4133,109 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d f2 = f_in2/dl ! Correction for the symmetric case if (diag_cs%G%symmetric) then - f1 = f1 + mod(f_in1,dl) - f2 = f2 + mod(f_in2,dl) + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) endif allocate(field_out(1:f1,1:f2)) if (method == MMP) then - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj)*weight - enddo ; enddo - field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj)*weight + enddo ; enddo + field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo elseif (method == SSP) then ! e.g., T_dfxy_cont_tendency_2d - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj)*weight - enddo ; enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo - elseif (method == PSP) then ! e.g., umo_2d - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj) - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight - enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo - elseif (method == SPP) then ! e.g., vmo_2d - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj) - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight - enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj)*weight + enddo ; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo + elseif (method == PSP) then ! e.g., umo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo + elseif (method == SPP) then ! e.g., vmo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo elseif (method == PMP) then - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight - enddo - field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo elseif (method == MPP) then - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight - enddo - field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo elseif (method == MSK) then !The input field is a mask, subsample - field_out(:,:) = 0.0 - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - ave = ave+field_in(ii,jj) - enddo ; enddo - if (ave > 0.0) field_out(i,j)=1.0 - enddo ; enddo + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave = ave+field_in(ii,jj) + enddo ; enddo + if (ave > 0.0) field_out(i,j)=1.0 + enddo ; enddo else - write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) endif end subroutine downsample_field_2d @@ -4266,13 +4265,13 @@ subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) field_out(:,:) = 0.0 do j=jsc_d,jec_d ; do i=isc_d,iec_d - i0 = isc_o+dl*(i-isc_d) - j0 = jsc_o+dl*(j-jsc_d) - tot_non_zero = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj) - enddo;enddo - if (tot_non_zero > 0.0) field_out(i,j)=1.0 + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo;enddo + if (tot_non_zero > 0.0) field_out(i,j)=1.0 enddo ; enddo end subroutine downsample_mask_2d @@ -4302,13 +4301,13 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) field_out(:,:,:) = 0.0 do k=ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d - i0 = isc_o+dl*(i-isc_d) - j0 = jsc_o+dl*(j-jsc_d) - tot_non_zero = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj,k) - enddo;enddo - if (tot_non_zero > 0.0) field_out(i,j,k)=1.0 + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo;enddo + if (tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo ; enddo ; enddo end subroutine downsample_mask_3d diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index fa29ad9a53..9422385a29 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -837,8 +837,8 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f elseif (INDEX(value_string(1),',') > 0) then ! Initialize vals with an invalid date. vals(:) = (/ -999, -999, -999, 0, 0, 0, 0 /) - read(value_string(1),*,end=995,err=1005) vals - 995 continue + read(value_string(1), *, end=995, err=1005) vals + 995 continue if ((vals(1) < 0) .or. (vals(2) < 0) .or. (vals(3) < 0)) & call MOM_error(FATAL,'read_param_time: integer list read error for time-type variable '//& trim(varname)// ' parsing "'//trim(value_string(1))//'"') @@ -865,8 +865,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f endif ; endif endif return - 1005 call MOM_error(FATAL,'read_param_time: read error for time-type variable '//& - trim(varname)// ' parsing "'//trim(value_string(1))//'"') + + 1005 call MOM_error(FATAL, 'read_param_time: read error for time-type variable '//& + trim(varname)// ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_time !> This function removes single and double quotes from a character string diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index cec61982cd..3bc5960f08 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -314,14 +314,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ISS => CS%ISS if (CS%rotate_index) then - allocate(sfc_state) - call rotate_surface_state(sfc_state_in,CS%Grid_in, sfc_state,CS%Grid,CS%turns) - allocate(fluxes) - call allocate_forcing_type(fluxes_in,G,fluxes) - call rotate_forcing(fluxes_in,fluxes,CS%turns) + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state, CS%Grid, CS%turns) + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, CS%turns) else - sfc_state=>sfc_state_in - fluxes=>fluxes_in + sfc_state => sfc_state_in + fluxes => fluxes_in endif ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed @@ -748,8 +748,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) call cpu_clock_end(id_clock_shelf) if (CS%rotate_index) then -! call rotate_surface_state(sfc_state,CS%Grid, sfc_state_in,CS%Grid_in,-CS%turns) - call rotate_forcing(fluxes,fluxes_in,-CS%turns) +! call rotate_surface_state(sfc_state,CS%Grid, sfc_state_in,CS%Grid_in,-CS%turns) + call rotate_forcing(fluxes,fluxes_in,-CS%turns) endif @@ -911,8 +911,8 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external endif if (CS%rotate_index .and. rotate) then - call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! TODO: deallocate mech forcing? + call rotate_mech_forcing(forces, -CS%turns, forces_in) + ! TODO: deallocate mech forcing? endif end subroutine add_shelf_forces @@ -1472,19 +1472,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (PRESENT(sfc_state_in)) then - allocate(sfc_state) - ! assuming frazil is enabled in ocean. This could break some configurations? - call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true.,& - do_integrals=.true.,omit_frazil=.false.,use_iceshelves=.true.) - if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in,CS%Grid_in, sfc_state,CS%Grid,CS%turns) - else - sfc_state=>sfc_state_in - endif + allocate(sfc_state) + ! assuming frazil is enabled in ocean. This could break some configurations? + call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & + do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) + if (CS%rotate_index) then + call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state,CS%Grid,CS%turns) + else + sfc_state=>sfc_state_in + endif endif - call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 + call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 if (read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & @@ -1688,8 +1688,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then - ! This model is initialized internally or from a file. - call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& + ! This model is initialized internally or from a file. + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& 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 @@ -1698,9 +1698,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif enddo ; enddo if (CS%debug) then - call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) - call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) - call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) + call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) endif ! else ! Previous block for new_sim=.T., this block restores the state. @@ -1840,9 +1840,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (present(fluxes_in) .and. CS%rotate_index) & - call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call rotate_forcing(fluxes, fluxes_in, -CS%turns) if (present(forces_in) .and. CS%rotate_index) & - call rotate_mech_forcing(forces, -CS%turns, forces_in) + call rotate_mech_forcing(forces, -CS%turns, forces_in) end subroutine initialize_ice_shelf @@ -1943,13 +1943,11 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) if (CS%rotate_index) then - allocate(tmp2d(CS%Grid_in%isc:CS%Grid_in%iec,CS%Grid_in%jsc:CS%Grid_in%jec)); tmp2d(:,:) = 0.0 + allocate(tmp2d(CS%Grid_in%isc:CS%Grid_in%iec,CS%Grid_in%jsc:CS%Grid_in%jec)) ; tmp2d(:,:) = 0.0 else - allocate(tmp2d(is:ie,js:je)) ; tmp2d(:,:) = 0.0 + allocate(tmp2d(is:ie,js:je)) ; tmp2d(:,:) = 0.0 endif - - call time_interp_external(CS%id_read_mass, Time, tmp2d) call rotate_array(tmp2d,CS%turns, ISS%mass_shelf) deallocate(tmp2d) @@ -1991,21 +1989,17 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h) real, optional, dimension(SZI_(G),SZJ_(G)) :: frac_shelf_h !< !< Ice shelf area fraction [nodim]. - logical :: do_frac=.false. - integer :: i,j - - if (present(frac_shelf_h)) do_frac=.true. + integer :: i, j - if (do_frac) then - do j=G%jsd,G%jed - do i=G%isd,G%ied - frac_shelf_h(i,j)=0.0 - if (G%areaT(i,j)>0.) frac_shelf_h(i,j) = CS%ISS%area_shelf_h(i,j) / G%areaT(i,j) - enddo - enddo - endif + if (present(frac_shelf_h)) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + frac_shelf_h(i,j) = 0.0 + if (G%areaT(i,j)>0.) frac_shelf_h(i,j) = CS%ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo + endif end subroutine ice_shelf_query + !> Save the ice shelf restart file subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_suffix) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index ab4245bd83..d8d3d5ebb0 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -154,18 +154,18 @@ subroutine set_axes_info(G, param_file, diag_cs, axes_set_name) endif if (G%symmetric) then - id_xq = diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + id_xq = diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'Boundary point nominal longitude',set_name=set_name, & Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + id_yq = diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & 'Boundary point nominal latitude', set_name=set_name, & Domain2=G%Domain%mpp_domain, domain_position=NORTH) else - id_xq = diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + id_xq = diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & 'Boundary point nominal longitude',set_name=set_name, & Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + id_yq = diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & 'Boundary point nominal latitude', set_name=set_name, & Domain2=G%Domain%mpp_domain, domain_position=NORTH) @@ -415,8 +415,8 @@ end function get_diag_time_end !> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one field. function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, conversion) result (register_diag_field) + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, conversion) result (register_diag_field) integer :: register_diag_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 @@ -512,8 +512,8 @@ end function register_MOM_IS_diag_field !> Registers a static diagnostic, returning an integer handle function register_static_field(module_name, field_name, axes, & - long_name, units, missing_value, range, mask_variant, standard_name, & - do_not_log, interp_method, tile_count) + long_name, units, missing_value, range, mask_variant, standard_name, & + do_not_log, interp_method, tile_count) 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 @@ -587,8 +587,8 @@ function i2s(a, n_in) i2s = '' do i=1,n - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) enddo i2s = adjustl(i2s) end function i2s diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 90c98fa487..9fe8028ac6 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -58,28 +58,26 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P if (PRESENT(rotate_index)) rotate=rotate_index if (rotate) then - allocate(tmp1_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed));tmp1_2d(:,:)=0.0 - allocate(tmp2_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed));tmp2_2d(:,:)=0.0 - allocate(tmp3_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed));tmp3_2d(:,:)=0.0 - select case ( trim(config) ) - case ("CHANNEL"); call initialize_ice_thickness_channel (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) - case ("FILE"); call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) - case ("USER"); call USER_init_ice_thickness (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) - case default ; call MOM_error(FATAL,"MOM_initialize: "// & - "Unrecognized ice profile setup "//trim(config)) - end select - call rotate_array(tmp1_2d,turns, h_shelf) - call rotate_array(tmp2_2d,turns, area_shelf_h) - call rotate_array(tmp3_2d,turns, hmask) - deallocate(tmp1_2d,tmp2_2d,tmp3_2d) + allocate(tmp1_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed)) ; tmp1_2d(:,:)=0.0 + allocate(tmp2_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed)) ; tmp2_2d(:,:)=0.0 + allocate(tmp3_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed)) ; tmp3_2d(:,:)=0.0 + select case ( trim(config) ) + case ("CHANNEL") ; call initialize_ice_thickness_channel (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case ("USER") ; call USER_init_ice_thickness (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) + end select + call rotate_array(tmp1_2d,turns, h_shelf) + call rotate_array(tmp2_2d,turns, area_shelf_h) + call rotate_array(tmp3_2d,turns, hmask) + deallocate(tmp1_2d,tmp2_2d,tmp3_2d) else - select case ( trim(config) ) - case ("CHANNEL"); call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF) - case ("FILE"); call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF) - case ("USER"); call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF) - case default ; call MOM_error(FATAL,"MOM_initialize: "// & - "Unrecognized ice profile setup "//trim(config)) - end select + select case ( trim(config) ) + case ("CHANNEL") ; call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("USER") ; call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF) + case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) + end select endif end subroutine initialize_ice_thickness From 6096c6c2ece1782fe2d2e80a76937eaf9bc44da7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Dec 2020 10:27:20 -0500 Subject: [PATCH 068/212] Corrected spacing around semicolons between dos Corrected non-standard spacing around semicolons separating do loops or if tests on a single line, following MOM6 code standards. (If Marshall wins his planned argument against allowing such constructs, this enforcement of standards will help in getting rid of them.) All answers are bitwise identical. --- src/core/MOM.F90 | 4 ++-- src/core/MOM_PressureForce_FV.F90 | 2 +- src/core/MOM_barotropic.F90 | 6 +++--- src/core/MOM_checksum_packages.F90 | 4 ++-- src/core/MOM_density_integrals.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 4 ++-- src/core/MOM_dynamics_unsplit.F90 | 12 +++++------ src/core/MOM_dynamics_unsplit_RK2.F90 | 4 ++-- src/core/MOM_interface_heights.F90 | 4 ++-- src/core/MOM_open_boundary.F90 | 10 +++++----- src/diagnostics/MOM_diagnostics.F90 | 8 ++++---- src/diagnostics/MOM_wave_speed.F90 | 2 +- src/framework/MOM_checksums.F90 | 8 ++++---- src/framework/MOM_diag_mediator.F90 | 4 ++-- src/framework/MOM_diag_remap.F90 | 6 +++--- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- .../MOM_shared_initialization.F90 | 4 ++-- .../MOM_state_initialization.F90 | 4 ++-- src/ocean_data_assim/MOM_oda_driver.F90 | 4 ++-- .../lateral/MOM_hor_visc.F90 | 14 +++++++------ .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 ++-- .../lateral/MOM_mixed_layer_restrat.F90 | 6 +++--- .../lateral/MOM_thickness_diffuse.F90 | 16 +++++++-------- .../vertical/MOM_ALE_sponge.F90 | 6 +++--- .../vertical/MOM_bulk_mixed_layer.F90 | 4 ++-- .../vertical/MOM_diabatic_aux.F90 | 2 +- .../vertical/MOM_geothermal.F90 | 2 +- .../vertical/MOM_opacity.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 6 +++--- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/tracer/MOM_offline_main.F90 | 6 +++--- src/tracer/MOM_tracer_advect.F90 | 4 ++-- src/tracer/MOM_tracer_diabatic.F90 | 20 +++++++++---------- src/tracer/RGC_tracer.F90 | 4 ++-- src/user/BFB_initialization.F90 | 2 +- src/user/DOME_initialization.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 2 +- 38 files changed, 101 insertions(+), 99 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3d8772e4a6..f228529004 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3324,7 +3324,7 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%ocean_heat(i,j) = 0.0 ; sfc_state%ocean_salt(i,j) = 0.0 enddo ; enddo !$OMP parallel do default(shared) private(mass) - do j=js,je ; do k=1,nz; do i=is,ie + do j=js,je ; do k=1,nz ; do i=is,ie mass = GV%H_to_RZ*h(i,j,k) sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + mass sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass * CS%tv%T(i,j,k) @@ -3365,7 +3365,7 @@ subroutine extract_surface_state(CS, sfc_state_in) if (CS%check_bad_sfc_vals) then numberOfErrors=0 ! count number of errors - do j=js,je; do i=is,ie + do j=js,je ; do i=is,ie if (G%mask2dT(i,j)>0.) then localError = sfc_state%sea_lev(i,j) <= -G%bathyT(i,j) & .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max & diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4c42807e9f..e5e37ecc8d 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -584,7 +584,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif !$OMP parallel do default(shared) - do j=Jsq,Jeq+1; do k=nz,1,-1 ; do i=Isq,Ieq+1 + 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 enddo ; enddo ; enddo diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index a2a14831e7..06b1e95edc 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1496,7 +1496,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the mass source, after first initializing the halos to 0. !$OMP do - do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then @@ -3807,13 +3807,13 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain FA_v_NN(i,j) = 0.0 ; FA_v_N0(i,j) = 0.0 ; FA_v_S0(i,j) = 0.0 ; FA_v_SS(i,j) = 0.0 enddo ; enddo !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie uBT_EE(I,j) = BT_cont%uBT_EE(I,j) ; uBT_WW(I,j) = BT_cont%uBT_WW(I,j) FA_u_EE(I,j) = BT_cont%FA_u_EE(I,j) ; FA_u_E0(I,j) = BT_cont%FA_u_E0(I,j) FA_u_W0(I,j) = BT_cont%FA_u_W0(I,j) ; FA_u_WW(I,j) = BT_cont%FA_u_WW(I,j) enddo ; enddo !$OMP do - do J=js-1,je; do i=is,ie + do J=js-1,je ; do i=is,ie vBT_NN(i,J) = BT_cont%vBT_NN(i,J) ; vBT_SS(i,J) = BT_cont%vBT_SS(i,J) FA_v_NN(i,J) = BT_cont%FA_v_NN(i,J) ; FA_v_N0(i,J) = BT_cont%FA_v_N0(i,J) FA_v_S0(i,J) = BT_cont%FA_v_S0(i,J) ; FA_v_SS(i,J) = BT_cont%FA_v_SS(i,J) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index e77f90925f..a1c300c94f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -106,8 +106,8 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. - hs=1; if (present(haloshift)) hs=haloshift - sym=.false.; if (present(symmetric)) sym=symmetric + 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=L_T_to_m_s) call hchksum(h, mesg//" h",G%HI, haloshift=hs, scale=GV%H_to_m) end subroutine MOM_state_chksum_3arg diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index d7d9c95b34..8d71cbcf65 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1372,7 +1372,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, enddo ! 1. Compute vertical integrals - do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + 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) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index dec97b6f98..4659973a3a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -441,9 +441,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") - if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + 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 + endif ; endif if (associated(CS%OBC) .and. CS%debug_OBC) & call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 193639becf..ed0bb907e5 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -316,9 +316,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + 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 + endif ; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) @@ -382,9 +382,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + 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 + endif ; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) @@ -457,9 +457,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + 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 + endif ; endif ! u = u + dt * ( PFu + CAu ) if (associated(CS%OBC)) then diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 429d150a63..dbb82eb44a 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -311,9 +311,9 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call pass_vector(CS%PFu, CS%PFv, G%Domain, clock=id_clock_pass) call pass_vector(CS%CAu, CS%CAv, G%Domain, clock=id_clock_pass) - if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then call update_OBC_data(CS%OBC, G, GV, US, tv, h_in, CS%update_OBC_CSp, Time_local) - endif; endif + endif ; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index f44becf78f..ec7501c5f0 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -76,7 +76,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (GV%Boussinesq) then !$OMP do - do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev + 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 enddo ; enddo ; enddo if (present(eta_bt)) then @@ -119,7 +119,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) enddo else !$OMP do - do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev + 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) enddo ; enddo ; enddo endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 25a76591b2..5e36801a19 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4336,12 +4336,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (trim(segment%field(m)%name) == 'TEMP') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(1)%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 + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) enddo ; enddo ; enddo segment%tr_Reg%Tr(1)%is_initialized=.true. @@ -4351,12 +4351,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif elseif (trim(segment%field(m)%name) == 'SALT') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(2)%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 + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) enddo ; enddo ; enddo segment%tr_Reg%Tr(2)%is_initialized=.true. @@ -5226,7 +5226,7 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) 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 + enddo ; enddo ! can not do communication call here since only PEs on the current segment are here diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e286d7bceb..c3a992b806 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -359,7 +359,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! mass per area of grid cell (for Bouss, use Rho0) if (CS%id_masscello > 0) then - do k=1,nz; do j=js,je ; do i=is,ie + 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) @@ -381,13 +381,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_thkcello > 0) then ; if (GV%H_to_Z == 1.0) then call post_data(CS%id_thkcello, h, CS%diag) else - do k=1,nz; do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_Z*h(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_thkcello, work_3d, CS%diag) endif ; endif if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq - do k=1,nz; do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = ( GV%H_to_Z*h(i,j,k) ) * US%Z_to_m*US%L_to_m**2*G%areaT(i,j) enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) @@ -421,7 +421,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ! j if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag) if (CS%id_volcello > 0) then - do k=1,nz; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq + do k=1,nz ; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 8b32e48788..035386f92d 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -170,7 +170,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ calc_modal_structure = l_use_ebt_mode if (present(modal_structure)) calc_modal_structure = .true. if (calc_modal_structure) then - do k=1,nz; do j=js,je; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie modal_structure(i,j,k) = 0.0 enddo ; enddo ; enddo endif diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 644a9fa43c..c3174dbe7b 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -413,7 +413,7 @@ integer function subchk(array, HI, di, dj, scale) real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 - do j=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di + do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,j))) subchk = subchk + bc enddo ; enddo @@ -693,7 +693,7 @@ integer function subchk(array, HI, di, dj, scale) integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. - do J=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di + do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,J))) subchk = subchk + bc enddo ; enddo @@ -983,7 +983,7 @@ integer function subchk(array, HI, di, dj, scale) integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. - do j=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di + do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,j))) subchk = subchk + bc enddo ; enddo @@ -1162,7 +1162,7 @@ integer function subchk(array, HI, di, dj, scale) integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. - do J=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di + do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,J))) subchk = subchk + bc enddo ; enddo diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 5c7106a7ae..fa4a4a2701 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -4270,7 +4270,7 @@ subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ tot_non_zero = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) - enddo;enddo + enddo ; enddo if (tot_non_zero > 0.0) field_out(i,j)=1.0 enddo ; enddo end subroutine downsample_mask_2d @@ -4306,7 +4306,7 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ tot_non_zero = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) - enddo;enddo + enddo ; enddo if (tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo ; enddo ; enddo end subroutine downsample_mask_3d diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 08d60b20e4..5c896c2d32 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -385,7 +385,7 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ remapped_field(:,:,:) = 0. ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0; if (G%symmetric) shift = 1 + shift = 0 ; if (G%symmetric) shift = 1 if (staggered_in_x .and. .not. staggered_in_y) then ! U-points @@ -516,7 +516,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered reintegrated_field(:,:,:) = 0. ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0; if (G%symmetric) shift = 1 + shift = 0 ; if (G%symmetric) shift = 1 if (staggered_in_x .and. .not. staggered_in_y) then ! U-points @@ -597,7 +597,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta nz_dest = remap_cs%nz ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0; if (G%symmetric) shift = 1 + shift = 0 ; if (G%symmetric) shift = 1 if (staggered_in_x .and. .not. staggered_in_y) then ! U-points diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3bc5960f08..22b4e226c8 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1736,7 +1736,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! do j=G%jsc,G%jec ; do i=G%isc,G%iec ! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) -! enddo; enddo +! enddo ; enddo CS%Time = Time diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index b230684c73..395cdcffd8 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1311,9 +1311,9 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) call create_file(unit, trim(filepath), vars, nFlds_used, fields, & file_threading, dG=G) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo ; enddo + do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLatBu(I,J) ; enddo ; enddo call write_field(unit, fields(1), G%Domain%mpp_domain, out_q) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo ; enddo + do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLonBu(I,J) ; enddo ; enddo call write_field(unit, fields(2), G%Domain%mpp_domain, out_q) call write_field(unit, fields(3), G%Domain%mpp_domain, G%geoLatT) call write_field(unit, fields(4), G%Domain%mpp_domain, G%geoLonT) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 93572b7939..b0dcb58609 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -219,7 +219,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This initialization should not be needed. Certainly restricting it ! to the computational domain helps detect possible uninitialized ! data in halos which should be covered by the pass_var(h) later. - !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(i,j,k) = 0. !enddo endif @@ -1889,7 +1889,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L 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 + 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)) enddo ; enddo ; enddo call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 26fa16d489..670be5d3fb 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -283,7 +283,7 @@ subroutine init_oda(Time, G, GV, CS) do k = 1, CS%nk call mpp_global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) - do i=1, CS%ni; do j=1, CS%nj + do i=1,CS%ni ; do j=1,CS%nj if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 endif @@ -337,7 +337,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) allocate(T(isd:ied,jsd:jed,CS%nk)) allocate(S(isd:ied,jsd:jed,CS%nk)) - do j=js,je; do i=is,ie + do j=js,je ; do i=is,ie call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & CS%nk, CS%h(i,j,:), T(i,j,:)) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index ffe97dffe8..53667bf646 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -425,7 +425,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 boundary_mask_q(I,J) = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * G%mask2dCu(I,j) * G%mask2dCu(I,j-1)) - enddo; enddo + enddo ; enddo ! initialize diag. array with zeros GME_coeff_h(:,:,:) = 0.0 @@ -442,7 +442,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) - & G%IdxCv(i,J-1) * vbtav(i,J-1)) - enddo; enddo + enddo ; enddo do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) @@ -688,7 +688,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Del2v(i,J) = CS%Idxdy2v(i,J)*(CS%dy2q(I,J)*sh_xy(I,J) - CS%dy2q(I-1,J)*sh_xy(I-1,J)) - & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*sh_xx(i,j+1) - CS%dx2h(i,j)*sh_xx(i,j)) enddo ; enddo - if (apply_OBC) then; if (OBC%zero_biharmonic) then + if (apply_OBC) then ; if (OBC%zero_biharmonic) then do n=1,OBC%number_of_segments I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then @@ -701,7 +701,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo endif enddo - endif; endif + endif ; endif endif ! Vorticity @@ -2223,7 +2223,8 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + we * GME_flux_h_original(i+1,j) & + ws * GME_flux_h_original(i,j-1) & + wn * GME_flux_h_original(i,j+1) - enddo; enddo + enddo + enddo endif ! Update halos if (present(GME_flux_q)) then @@ -2245,7 +2246,8 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + we * GME_flux_q_original(I+1,J) & + ws * GME_flux_q_original(I,J-1) & + wn * GME_flux_q_original(I,J+1) - enddo; enddo + enddo + enddo endif enddo ! s-loop end subroutine smooth_GME diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 37fcd15f6a..33c333906f 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2384,7 +2384,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. - do i=isd,ied; do j=jsd,jed + 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 enddo ; enddo diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 9fdd701da1..e3a6f1599e 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1105,10 +1105,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%Visbeck_L_scale<0) then do j=js,je ; do I=is-1,Ieq CS%L2u(I,j) = CS%Visbeck_L_scale**2 * G%areaCu(I,j) - enddo; enddo + enddo ; enddo do J=js-1,Jeq ; do i=is,ie CS%L2v(i,J) = CS%Visbeck_L_scale**2 * G%areaCv(i,J) - enddo; enddo + 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 diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 2834f87121..b370332d90 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -664,7 +664,7 @@ 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 + 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)) @@ -707,7 +707,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) uDml_diag(I,j) = uDml(I) utimescale_diag(I,j) = timescale - enddo; enddo + enddo ; enddo ! V- component !$OMP do @@ -753,7 +753,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vtimescale_diag(i,J) = timescale vDml_diag(i,J) = vDml(i) - enddo; enddo + enddo ; enddo !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a198c9c85a..8c6a90ba9c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -213,7 +213,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp !$OMP int_slope_v,khth_use_ebt_struct, Depth_scaled, & !$OMP Khth_loc_v) !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = CS%Khth enddo ; enddo @@ -244,31 +244,31 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (Resoln_scaled) then !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Res_fn_u(I,j) enddo ; enddo endif if (Depth_scaled) then !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Depth_fn_u(I,j) enddo ; enddo endif if (CS%Khth_Max > 0) then !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, min(Khth_loc_u(I,j), CS%Khth_Max)) enddo ; enddo else !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, Khth_loc_u(I,j)) enddo ; enddo endif !$OMP do - do j=js,je; do I=is-1,ie + do j=js,je ; do I=is-1,ie KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) enddo ; enddo @@ -330,7 +330,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (Resoln_scaled) then !$OMP do - do J=js-1,je; do i=is,ie + do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Res_fn_v(i,J) enddo ; enddo endif @@ -501,7 +501,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp do k=1,nz do j=js,je ; do i=is,ie MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) + Kh_t(i,j,k) * h(i,j,k) - enddo; enddo + enddo ; enddo enddo do j=js,je ; do i=is,ie diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index b794d5aa89..64eb80acb5 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -299,7 +299,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -486,7 +486,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 ! u points CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 @@ -512,7 +512,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 3bea0d9937..4a9d428807 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -2641,12 +2641,12 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, dT_dS_gauge*dRcv_dT(i)*(S(i,k1)-S(i,kb2)) if (dSpice_det*dSpice_lim <= 0.0) dSpice_lim = 0.0 endif - if (k1 10.0*Angstrom) then + if (k1 10.0*Angstrom) then dSpice_lim2 = dS_dT_gauge*dRcv_dS(i)*(T(i,k1+1)-T(i,kb2)) - & dT_dS_gauge*dRcv_dT(i)*(S(i,k1+1)-S(i,kb2)) if ((dSpice_det*dSpice_lim2 > 0.0) .and. & (abs(dSpice_lim2) > abs(dSpice_lim))) dSpice_lim = dSpice_lim2 - endif; endif + endif ; endif if (abs(dSpice_det) > abs(dSpice_lim)) dSpice_det = dSpice_lim I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 8b72809837..470098a08a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -847,7 +847,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) PE_threshold(iM) = Mixing_Energy(iM)/GV%g_earth enddo - do j=js,je; do i=is,ie + do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index a02d07ffef..be390ef50f 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -340,7 +340,7 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (CS%id_internal_heat_temp_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = Idt * (tv%T(i,j,k) - T_old(i,j,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_internal_heat_temp_tendency, work_3d, CS%diag, alt_h=h_old) endif if (CS%id_internal_heat_h_tendency > 0) then diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index cbd2731d39..c553c41fc6 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -281,7 +281,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir chl_data(:,:) = 0.0 if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,1) ; enddo ; enddo - do k=1,nz; do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_3d(i,j,k) < 0.0)) then write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", & & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d2400820da..40f6ca8c6a 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1475,7 +1475,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS endif if (len_trim(CS%u_trunc_file) > 0) then - do j=js,je; do I=Isq,Ieq ; if (dowrite(I,j)) then + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & @@ -1518,7 +1518,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS endif ; enddo if (trunc_any) then ; if (CS%CFL_based_trunc) then - do k=1,nz; do i=is,ie + do k=1,nz ; do i=is,ie if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 @@ -1560,7 +1560,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS endif if (len_trim(CS%v_trunc_file) > 0) then - do J=Jsq,Jeq; do i=is,ie ; if (dowrite(i,J)) then + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 279f6e901c..67a2519f78 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -325,7 +325,7 @@ 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 call boundary_k_range(SURFACE, GV%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) - enddo; enddo + enddo ; enddo ! TODO: add similar code for BOTTOM boundary layer endif diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index ca8d1fdde8..408120b4e5 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -370,7 +370,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock endif endif - do k=1,nz; do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie uhtr_sub(I,j,k) = uhtr(I,j,k) vhtr_sub(i,J,k) = vhtr(i,J,k) enddo ; enddo ; enddo @@ -633,7 +633,7 @@ real function remaining_transport_sum(CS, uhtr, vhtr) h_min = CS%GV%H_subroundoff remaining_transport_sum = 0. - do k=1,nz; do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie uh_neglect = h_min*CS%G%US%L_to_m**2*MIN(CS%G%areaT(i,j),CS%G%areaT(i+1,j)) vh_neglect = h_min*CS%G%US%L_to_m**2*MIN(CS%G%areaT(i,j),CS%G%areaT(i,j+1)) if (ABS(uhtr(I,j,k))>uh_neglect) then @@ -990,7 +990,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, sum_abs_fluxes = 0.0 sum_u = 0.0 sum_v = 0.0 - do k=1,nz; do j=js,je; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie sum_u = sum_u + abs(uhtr(I-1,j,k))+abs(uhtr(I,j,k)) sum_v = sum_v + abs(vhtr(i,J-1,k))+abs(vhtr(I,J,k)) sum_abs_fluxes = sum_abs_fluxes + abs(eatr(i,j,k)) + abs(ebtr(i,j,k)) + abs(uhtr(I-1,j,k)) + & diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 87a8c8f9a4..f3e80c791e 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -223,12 +223,12 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then - do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then + do i=isv+stencil-1,iev-stencil ; if (uhr(I,j,k) /= 0.0) then domore_u(j,k) = .true. ; exit endif ; enddo ! i-loop endif ; enddo do J=jsv+stencil-1,jev-stencil ; if (.not.domore_v(J,k)) then - do i=isv+stencil,iev-stencil; if (vhr(i,J,k) /= 0.0) then + do i=isv+stencil,iev-stencil ; if (vhr(i,J,k) /= 0.0) then domore_v(J,k) = .true. ; exit endif ; enddo ! i-loop endif ; enddo diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 01f9e5d5c7..567fa2897e 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -86,16 +86,16 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & if (present(sink_rate)) sink_dist = (dt*sink_rate) * GV%m_to_H !$OMP parallel default(shared) private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) !$OMP do - do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo + do j=js,je ; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo if (present(sfc_flux)) then if (convert_flux) then !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H enddo ; enddo else !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie sfc_src(i,j) = sfc_flux(i,j) enddo ; enddo endif @@ -103,12 +103,12 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & if (present(btm_flux)) then if (convert_flux) then !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H enddo ; enddo else !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie btm_src(i,j) = btm_flux(i,j) enddo ; enddo endif @@ -286,16 +286,16 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & if (present(sink_rate)) sink_dist = (dt*sink_rate) * GV%m_to_H !$OMP parallel default(shared) private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) !$OMP do - do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo + do j=js,je ; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo if (present(sfc_flux)) then if (convert_flux) then !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H enddo ; enddo else !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie sfc_src(i,j) = sfc_flux(i,j) enddo ; enddo endif @@ -303,12 +303,12 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & if (present(btm_flux)) then if (convert_flux) then !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H enddo ; enddo else !$OMP do - do j = js, je; do i = is,ie + do j=js,je ; do i=is,ie btm_src(i,j) = btm_flux(i,j) enddo ; enddo endif diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 8380aa86b6..59058abeda 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -237,7 +237,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then temp(i,j,k) = 0.0 endif - enddo ; enddo; enddo + enddo ; enddo ; enddo do m=1,1 ! This is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) @@ -253,7 +253,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then temp(i,j,k) = 0.0 endif - enddo ; enddo; enddo + enddo ; enddo ; enddo do m=1,1 tr_ptr => CS%tr(:,:,:,m) call set_up_sponge_field(temp, tr_ptr, G, GV, nz, layer_CSp) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 48708794fd..f632b95086 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -128,7 +128,7 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para max_damping = 1.0 / (86400.0*US%s_to_T) - do i=is,ie; do j=js,je + do j=js,je ; do i=is,ie if (G%bathyT(i,j) <= min_depth) 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 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 4a42ce64ad..9e749b8315 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -184,7 +184,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) H0(1) = 0.0 do k=2,nz ; H0(k) = -(real(k-1)-0.5)*G%max_depth / real(nz-1) ; enddo - do i=is,ie; do j=js,je + do j=js,je ; do i=is,ie if (G%geoLonT(i,j) < 100.0) then ; damp = 10.0 elseif (G%geoLonT(i,j) < 200.0) then damp = 10.0 * (200.0-G%geoLonT(i,j))/100.0 diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index c6e8910def..ac8bdfa70e 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -509,7 +509,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. - do i=is,ie; do j=js,je + do j=js,je ; do i=is,ie if (G%bathyT(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 From 6d59996394bd7637a6749c09454381c6b868af94 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Dec 2020 14:16:07 -0500 Subject: [PATCH 069/212] Corrected an OMP directive Added GV to the shared declaration in an openMP directive. All answers are bitwise identical. --- src/core/MOM_CoriolisAdv.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index becf3c422e..8dab711d32 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -269,7 +269,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) (Area_h(i+1,j) + Area_h(i,j+1)) enddo ; enddo - !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,CS,AD,Area_h,Area_q,& + !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) do k=1,nz @@ -925,20 +925,20 @@ end subroutine CorAdCalc !> Calculates the acceleration due to the gradient of kinetic energy. subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocen 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(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + type(ocean_grid_type), intent(in) :: G !< Ocen 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(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic !! energy gradient [L T-2 ~> m s-2] real, dimension(SZI_(G) ,SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic !! energy gradient [L T-2 ~> m s-2] - integer, intent(in) :: k !< Layer number to calculate for + integer, intent(in) :: k !< Layer number to calculate for type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv + type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv ! Local variables real :: um, up, vm, vp ! Temporary variables [L T-1 ~> m s-1]. real :: um2, up2, vm2, vp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. From 70622895b6b71f1bea25bc0201fbae3ad38cf91b Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 9 Dec 2020 12:59:09 -0500 Subject: [PATCH 070/212] switch to different tridiag solver --- src/ALE/regrid_edge_values.F90 | 1 + src/diagnostics/MOM_wave_structure.F90 | 10 ++++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 46570b26b9..d9c25d8cd1 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -16,6 +16,7 @@ module regrid_edge_values public edge_values_explicit_h2, edge_values_explicit_h4 public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 +public solve_diag_dominant_tridiag ! public solve_diag_dominant_tridiag, linear_solver ! The following parameters are used to avoid singular matrices for boundary diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index b0c543f12f..35fbe33218 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -21,6 +21,7 @@ module MOM_wave_structure use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use regrid_edge_values, only : solve_diag_dominant_tridiag implicit none ; private @@ -464,8 +465,13 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Perform inverse iteration with tri-diag solver do itt=1,max_itt - 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_H",e_itt) + ! this solver becomes unstable very quickly + !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( a_diag(1:kc-1), -lam_z(1:kc-1), & + c_diag(1:kc-1), e_guess(1:kc-1), & + e_itt, kc-1 ) e_guess(1:kc-1) = e_itt(1:kc-1) / sqrt(sum(e_itt(1:kc-1)**2)) enddo ! itt-loop w_strct(2:kc) = e_guess(1:kc-1) From 723bfdbe81e1f1af167a4d1827da9ad0d79dd7e7 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 9 Dec 2020 13:28:59 -0500 Subject: [PATCH 071/212] fix comments doxygen --- src/diagnostics/MOM_wave_structure.F90 | 114 ++++++++++++------------- 1 file changed, 57 insertions(+), 57 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 35fbe33218..44a00095cc 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -110,81 +110,81 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !! over the entire computational domain. ! Local variables real, dimension(SZK_(G)+1) :: & - dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [R L H T-2 ~> Pa] - T_int, & ! Temperature interpolated to interfaces [degC] - S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + dRho_dT, & !< Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & !< Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + pres, & !< Interface pressure [R L H T-2 ~> Pa] + T_int, & !< Temperature interpolated to interfaces [degC] + S_int, & !< Salinity interpolated to interfaces [ppt] + gprime !< The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & - Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [T2 L-2 ~> s2 m-2]. + 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_(G),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] - Tf, & ! Layer temperatures after very thin layers are combined [degC] - Sf, & ! Layer salinities after very thin layers are combined [ppt] - Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] + Hf, & !< Layer thicknesses after very thin layers are combined [Z ~> m] + Tf, & !< Layer temperatures after very thin layers are combined [degC] + Sf, & !< Layer salinities after very thin layers are combined [ppt] + Rf !< Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & - Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] - Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] - Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] - Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] + Hc, & !< A column of layer thicknesses after convective istabilities are removed [Z ~> m] + Tc, & !< A column of layer temperatures after convective istabilities are removed [degC] + Sc, & !< A column of layer salinites after convective istabilities are removed [ppt] + Rc, & !< A column of layer densities after convective istabilities are removed [R ~> kg m-3] det, ddet real, dimension(SZI_(G),SZJ_(G)) :: & - htot ! 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] + 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 [degC Z ~> degC m] - HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] - HxR_here ! A layer integrated density [R Z ~> kg m-2] + hmin, & !< Thicknesses [Z ~> m] + H_here, & !< A thickness [Z ~> m] + HxT_here, & !< A layer integrated temperature [degC Z ~> degC m] + HxS_here, & !< A layer integrated salinity [ppt Z ~> ppt m] + HxR_here !< A layer integrated density [R Z ~> kg m-2] real :: speed2_tot - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] + real :: I_Hnew !< The inverse of a new layer thickness [Z-1 ~> m-1] + real :: drxh_sum !< The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + 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] - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + 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] + 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_(G)+1) :: w_strct ! Vertical structure of vertical velocity (normalized) [nondim]. - real, dimension(SZK_(G)+1) :: u_strct ! Vertical structure of horizontal velocity (normalized) [nondim]. - real, dimension(SZK_(G)+1) :: W_profile ! Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, dimension(SZK_(G)+1) :: Uavg_profile ! Vertical profile of the magnitude of horizontal velocity [L T-1 ~> m s-1]. - real, dimension(SZK_(G)+1) :: z_int ! Integrated depth [Z ~> m] - real, dimension(SZK_(G)+1) :: N2 ! Squared buoyancy frequency at each interface [T-2 ~> s-2]. - real, dimension(SZK_(G)+1) :: w_strct2 ! squared values [nondim] - real, dimension(SZK_(G)+1) :: u_strct2 ! squared values [nondim] - real, dimension(SZK_(G)) :: dz ! thicknesses of merged layers (same as Hc I hope) [Z ~> m] - ! real, dimension(SZK_(G)+1) :: dWdz_profile ! profile of dW/dz - real :: w2avg ! average of squared vertical velocity structure funtion [Z ~> m] + real, dimension(SZK_(G)+1) :: w_strct !< Vertical structure of vertical velocity (normalized) [nondim]. + real, dimension(SZK_(G)+1) :: u_strct !< Vertical structure of horizontal velocity (normalized) [nondim]. + real, dimension(SZK_(G)+1) :: W_profile !< Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. + real, dimension(SZK_(G)+1) :: Uavg_profile !< Vertical profile of the magnitude of horizontal velocity [L T-1 ~> m s-1]. + real, dimension(SZK_(G)+1) :: z_int !< Integrated depth [Z ~> m] + real, dimension(SZK_(G)+1) :: N2 !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. + real, dimension(SZK_(G)+1) :: w_strct2 !< squared values [nondim] + real, dimension(SZK_(G)+1) :: u_strct2 !< squared values [nondim] + real, dimension(SZK_(G)) :: dz !< thicknesses of merged layers (same as Hc I hope) [Z ~> m] + ! real, dimension(SZK_(G)+1) :: dWdz_profile !< profile of dW/dz + real :: w2avg !< average of squared vertical velocity structure funtion [Z ~> m] real :: int_dwdz2 real :: int_w2 real :: int_N2w2 - real :: KE_term ! terms in vertically averaged energy equation - real :: PE_term ! terms in vertically averaged energy equation - real :: W0 ! A vertical velocity magnitude [Z T-1 ~> m s-1] - real :: gp_unscaled ! A version of gprime rescaled to [L T-2 ~> m s-2]. - real, dimension(SZK_(G)-1) :: lam_z ! product of eigen value and gprime(k); one value for each - ! interface (excluding surface and bottom) + real :: KE_term !< terms in vertically averaged energy equation + real :: PE_term !< terms in vertically averaged energy equation + real :: W0 !< A vertical velocity magnitude [Z T-1 ~> m s-1] + real :: gp_unscaled !< A version of gprime rescaled to [L T-2 ~> m s-2]. + real, dimension(SZK_(G)-1) :: lam_z !< product of eigen value and gprime(k); one value for each + !< interface (excluding surface and bottom) real, dimension(SZK_(G)-1) :: a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) - real, dimension(SZK_(G)-1) :: e_guess ! guess at eigen vector with unit amplitde (for TDMA) - real, dimension(SZK_(G)-1) :: e_itt ! improved guess at eigen vector (from TDMA) + !< diagonals of tridiagonal matrix; one value for each + !< interface (excluding surface and bottom) + real, dimension(SZK_(G)-1) :: e_guess !< guess at eigen vector with unit amplitde (for TDMA) + real, dimension(SZK_(G)-1) :: e_itt !< improved guess at eigen vector (from TDMA) real :: Pi integer :: kc integer :: i, j, k, k2, itt, is, ie, js, je, nz, nzm, row, ig, jg, ig_stop, jg_stop From 37cea3690583bc2402d2c59965b9775653290ebb Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 9 Dec 2020 11:37:17 -0900 Subject: [PATCH 072/212] A few fixes to get it to compile with gfortran. --- config_src/nuopc_driver/mom_cap.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index c2a2e98838..fc6bb5035e 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -353,7 +353,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) file=__FILE__)) & return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_count + read(value, *, iostat=iostat) scalar_field_count if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldCount not an integer: "//trim(value), & @@ -376,7 +376,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) file=__FILE__)) & return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx + read(value, *, iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & @@ -399,7 +399,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) file=__FILE__)) & return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny + read(value, *, iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & @@ -1434,14 +1434,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !--------------------------------- if (len_trim(scalar_field_name) > 0) then - call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & + call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return - call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & + call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & From 37e799ebc17fd438522dd409f8bc32a7c5e9fd63 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 11 Dec 2020 11:10:23 -0500 Subject: [PATCH 073/212] split comment --- src/diagnostics/MOM_wave_structure.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 44a00095cc..b647731460 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -163,7 +163,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real, dimension(SZK_(G)+1) :: w_strct !< Vertical structure of vertical velocity (normalized) [nondim]. real, dimension(SZK_(G)+1) :: u_strct !< Vertical structure of horizontal velocity (normalized) [nondim]. real, dimension(SZK_(G)+1) :: W_profile !< Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, dimension(SZK_(G)+1) :: Uavg_profile !< Vertical profile of the magnitude of horizontal velocity [L T-1 ~> m s-1]. + real, dimension(SZK_(G)+1) :: Uavg_profile !< Vertical profile of the magnitude of + !! horizontal velocity [L T-1 ~> m s-1]. real, dimension(SZK_(G)+1) :: z_int !< Integrated depth [Z ~> m] real, dimension(SZK_(G)+1) :: N2 !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. real, dimension(SZK_(G)+1) :: w_strct2 !< squared values [nondim] From cf97095bdab4b50a32f9d28711d0b6224455ce21 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 14 Dec 2020 12:50:17 -0700 Subject: [PATCH 074/212] Fix bug in linear decay and set F_layer = 0 below htot_max --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 40 ++++++++++++++----- 1 file changed, 31 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d4eab3f90f..e1b725e82a 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -602,6 +602,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ 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 + real :: htot_max !< depth below which no fluxes should be applied integer :: nk !< number of layers in the LBD grid F_layer(:) = 0.0 @@ -640,12 +641,12 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ phi_R_z(k), dz_top(k), dz_top(k)) enddo htot = 0.0 - do k = k_bot_min,k_bot_max, 1 + do k = k_bot_min+1,k_bot_max, 1 htot = htot + dz_top(k) enddo a = -1.0/htot - htot = dz_top(k_bot_min) + 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 @@ -684,19 +685,40 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! 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 native grid + + ! remap flux to h_vel (native grid) call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) - ! apply flux_limiter in the native grid - if (CS%limiter) then - do k = 1,ke - if (F_layer(k) /= 0.) call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), & - phi_R(k), h_L(k), h_R(k)) - enddo + + ! 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 + tmp1 = tmp1 + h_L(k) + tmp2 = tmp2 + h_R(k) + + ! 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) From 54d201fcbbf6d8dfa9ad8d16a53f46a6fb27b459 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 14 Dec 2020 18:02:14 -0500 Subject: [PATCH 075/212] fix out of bounds with full halos --- src/diagnostics/MOM_wave_structure.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index b647731460..05494fb819 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -510,8 +510,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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(I-1,J-1) + & - G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J)))**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 = (freq**2 - f2) / (cn(i,j)**2 + cg_subRO**2) ! Calculate terms in vertically integrated energy equation From 8426fe7ab07f57a53e3f0e882c24a774ed8beb81 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 14 Dec 2020 18:04:14 -0500 Subject: [PATCH 076/212] fix diag write error --- src/parameterizations/vertical/MOM_internal_tide_input.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 059f5b9ab6..79c69be095 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -115,6 +115,8 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_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)) @@ -123,7 +125,6 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%int_tide_source_test) then itide%TKE_itidal_input(:,:) = 0.0 - avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) if (time_end <= CS%time_max_source) then do j=js,je ; do i=is,ie ! Input an arbitrary energy point source.id_ From 51ed387aef321d5b9b0fe5e09426d300c9d19465 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 15 Dec 2020 18:05:27 -0700 Subject: [PATCH 077/212] Delete forgotten code --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d155a782d0..570b4b9ad8 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -702,9 +702,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ tmp1 = 0.0; tmp2 = 0.0 do k = 1,ke - tmp1 = tmp1 + h_L(k) - tmp2 = tmp2 + h_R(k) - ! 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)) From 9d04f384935904f04ab80a2d4385cd562fe0eee3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 17 Dec 2020 17:59:37 -0700 Subject: [PATCH 078/212] Sets CS%limiter_remap=.false. in near_boundary_unit_tests --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 570b4b9ad8..2b7a5646cc 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -753,6 +753,7 @@ logical function near_boundary_unit_tests( verbose ) 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 =======================' From 53ff6dc55ce624725942ab209e229511d8c1dcc9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 18 Dec 2020 19:53:24 -0500 Subject: [PATCH 079/212] Doxygen fixes to MOM_lateral_boundary_diffusion Doxygen was not assigning some docstrings for multiline variable declarations, so this patch splits those variables to one per line, with updated docstrings. Whitespace was also condensed in several of the declarations. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 33 +++++++++++-------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 2b7a5646cc..9225b16b13 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -314,13 +314,14 @@ 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, e !< start and end indices - real, dimension(e), intent(in) :: x !< 1D array to be checked + 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 + real :: minimum + integer :: location + integer :: i minimum = x(s) ! assume the first is the min location = s ! record its position @@ -335,13 +336,15 @@ end function find_minimum !> Swaps the values of its two formal arguments. subroutine swap(a, b) - real, intent(inout) :: a, b !< values to be swaped + real, intent(inout) :: a !< First value to be swaped + real, intent(inout) :: b !< Second value to be swaped ! local variables - real :: tmp + real :: tmp + tmp = a - a = b - b = tmp + a = b + b = tmp end subroutine swap !> Receives a 1D array x and sorts it into ascending order. @@ -461,11 +464,13 @@ 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_R !< Area of left and right cells [L2 ~> m2] - real, intent(in ) :: h_L, h_R !< Thickness of left and right cells [H ~> m or kg m-2] - real, intent(in ) :: phi_L, phi_R !< Tracer concentration in the left and right cells - !! [conc] + 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 From 3e99462ca4d31c31ef77f56b61b745edb468f2b5 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 18 Dec 2020 21:00:45 -0500 Subject: [PATCH 080/212] Line length fix in MOM_lateral_boundary_diffusion.F90 Reduction in line length of any lines exceeding 120 characters. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 9225b16b13..77176fa047 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -584,12 +584,13 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer ! Local variables - real, dimension(:), allocatable :: dz_top !< The LBD z grid to be created [L ~ m] - real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] - real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] - real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U- or V-point in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(:), allocatable :: dz_top !< The LBD z grid to be created [L ~ m] + real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] + real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] + real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U- or V-points 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] + !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. From d502516329fe3ebb28f5465d9ef10d4486f5c674 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Sat, 19 Dec 2020 22:56:26 -0500 Subject: [PATCH 081/212] minor enhancement in MOM_wave_interface.F90 to aviod undocumented error --- src/user/MOM_wave_interface.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 4ba1b779e3..e79f7b65ef 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -466,6 +466,12 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) if (DataSource==DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) elseif (DataSource==Coupler) then + if (.not.present(FORCES)) then + call MOM_error(FATAL,"The code cannot be run with the options "//& + "SURFBAND_SOURCE = COUPLER for with this driver. If you are using a "//& + "wave coupled driver then check the call to update_surface_waves, otherwise"//& + "select another option for SURFBAND_SOURCE.") + endif if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& From 1d89598c042029a90d223aa3828385cc54da3888 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Mon, 21 Dec 2020 09:25:52 -0700 Subject: [PATCH 082/212] correct CFC index check in src/tracer/MOM_OCMIP2_CFC.F90 --- src/tracer/MOM_OCMIP2_CFC.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 9aad84a6dd..c568f4cacc 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -126,7 +126,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This call sets default properties for the air-sea CFC fluxes and obtains the ! indicies for the CFC11 and CFC12 flux coupling. call flux_init_OCMIP2_CFC(CS, verbosity=3) - if ((CS%ind_cfc_11_flux < 0) .or. (CS%ind_cfc_11_flux < 0)) then + if ((CS%ind_cfc_11_flux < 0) .or. (CS%ind_cfc_12_flux < 0)) then ! This is most likely to happen with the dummy version of aof_set_coupler_flux ! used in ocean-only runs. call MOM_ERROR(WARNING, "CFCs are currently only set up to be run in " // & From 2c93933a971e9054058ff3512c79622ff3a9cd92 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 21 Dec 2020 12:43:08 -0500 Subject: [PATCH 083/212] Revert changes in the MOM drivers for ice shelf initialization - Call ice shelf initialization from within initialize_MOM. --- config_src/solo_driver/MOM_driver.F90 | 28 +++++++++++++-------------- src/core/MOM.F90 | 11 ++++++++--- src/ice_shelf/MOM_ice_shelf.F90 | 15 ++++++++------ 3 files changed, 31 insertions(+), 23 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 9981f291b1..3e11299cea 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -307,20 +307,8 @@ program MOM_main Time = Start_time endif - ! 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) - - call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) - if (use_ice_shelf) then - ! These arrays are not initialized in most solo cases, but are needed - ! when using an ice shelf - call initialize_ice_shelf(param_file, grid, Time, ice_shelf_CSp, & - diag_IS, forces, fluxes, sfc_state) - endif - call close_param_file(param_file) - + ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers + ! initialization of ice shelf parameters and arrays. if (sum(date) >= 0) then call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & @@ -331,6 +319,18 @@ program MOM_main tracer_flow_CSp=tracer_flow_CSp,ice_shelf_CSp=ice_shelf_CSp) endif + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + + if (use_ice_shelf) then + ! These arrays are not initialized in most solo cases, but are needed + ! when using an ice shelf + ice_shelf_CSp => NULL() ! Reset the pointer and make another call to reinitialize + ! the ice shelf and associated forcing types + call initialize_ice_shelf(param_file, grid, Time, ice_shelf_CSp, & + diag, forces, fluxes, sfc_state) + endif + call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) Master_Time = Time diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3f4507f546..fa7c3ca565 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -141,7 +141,7 @@ module MOM use MOM_offline_main, only : offline_fw_fluxes_into_ocean, offline_fw_fluxes_out_ocean use MOM_offline_main, only : offline_advection_layer, offline_transport_end use MOM_ALE, only : ale_offline_tracer_final, ALE_main_offline -use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query +use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query, initialize_ice_shelf implicit none ; private @@ -2037,7 +2037,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & use_ice_shelf=.false. if (present(ice_shelf_CSp)) then - if (associated(ice_shelf_CSp)) use_ice_shelf=.true. + call get_param(param_file, "MOM", "ICE_SHELF", use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) endif CS%ensemble_ocean=.false. @@ -2381,6 +2382,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (use_ice_shelf) then + ! 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) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed)) frac_shelf_in(:,:) = 0.0 allocate(CS%frac_shelf_h(isd:ied, jsd:jed)) @@ -2431,10 +2436,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & deallocate(frac_shelf_in) else if (use_ice_shelf) then + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr) allocate(CS%frac_shelf_h(isd:ied, jsd:jed)) CS%frac_shelf_h(:,:) = 0.0 call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h) - call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in, & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 92545d6dc4..88ad6c7123 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -9,6 +9,7 @@ module MOM_ice_shelf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_coms, only : num_PEs +use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl use MOM_IS_diag_mediator, only : post_data, register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr use MOM_IS_diag_mediator, only : set_axes_info use MOM_IS_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid, diag_ctrl, time_type @@ -1156,7 +1157,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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(diag_ctrl), pointer :: diag !< A structure that is used to regulate the diagnostic output. + type(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS + !! which will be discarded + 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 !! possible thermodynamic or mass-flux forcing fields. @@ -1284,11 +1287,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif G=>CS%Grid - allocate(diag) - call diag_mediator_init(G, param_file,diag,component='MOM_IceShelf') + allocate(CS%diag) + call diag_mediator_init(G, param_file,CS%diag,component='MOM_IceShelf') ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. - call set_axes_info(G, param_file, diag) + call set_axes_info(G, param_file, CS%diag) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1302,7 +1305,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! Convenience pointers OG => CS%ocn_grid US => CS%US - CS%diag=>diag + !CS%diag=>diag ! Are we being called from the solo ice-sheet driver? When called by the ocean ! model solo_ice_sheet_in is not preset. @@ -1777,7 +1780,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif if (shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, diag, new_sim, solo_ice_sheet_in) + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, solo_ice_sheet_in) call fix_restart_unit_scaling(US) From f3dc73f7b78770c2e857e31a1441ebb5ca88ba2e Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 21 Dec 2020 13:10:19 -0500 Subject: [PATCH 084/212] Revert forcing,fluxes and sfc_state from pointers. - This removes suppport for rotation. --- config_src/solo_driver/MOM_driver.F90 | 9 +++-- src/ice_shelf/MOM_ice_shelf.F90 | 51 ++++++++++++++------------- 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 3e11299cea..d61d6c986a 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -80,13 +80,12 @@ program MOM_main #include ! A structure with the driving mechanical surface forces - type(mech_forcing), pointer :: forces => NULL() + type(mech_forcing) :: forces ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. - type(forcing), pointer :: fluxes => NULL() - + type(forcing) :: fluxes ! A structure containing pointers to the ocean surface state fields. - type(surface), pointer :: sfc_state => NULL() + type(surface) :: sfc_state ! A pointer to a structure containing metrics and related information. type(ocean_grid_type), pointer :: grid => NULL() @@ -221,7 +220,7 @@ program MOM_main call MOM_infra_init() ; call io_infra_init() - allocate(forces,fluxes,sfc_state) + !allocate(forces,fluxes,sfc_state) ! Initialize the ensemble manager. If there are no settings for ensemble_size ! in input.nml(ensemble.nml), these should not do anything. In coupled diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 88ad6c7123..3638652bfc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -807,18 +807,18 @@ end subroutine change_thickness_using_melt !> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on !! the ice state in ice_shelf_CS. -subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external_call) +subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) type(ocean_grid_type), intent(in) :: Ocn_grid !< 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(mech_forcing),target, intent(inout) :: forces_in !< A structure with the + type(mech_forcing), intent(inout) :: forces !< A structure with the !! driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. logical, optional, intent(in) :: external_call !< If true the incoming forcing type !! is using the input grid metric and needs !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. - type(mech_forcing), pointer :: forces => NULL() !< A structure with the driving mechanical forces +! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -830,20 +830,25 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external if (present(external_call)) rotate=external_call - if (CS%rotate_index .and. rotate) then - if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") - - allocate(forces) - call allocate_mech_forcing(forces_in, CS%Grid, forces) - call rotate_mech_forcing(forces_in, CS%turns, forces) - else - if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & - (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") - forces=>forces_in + if (CS%rotate_index .and. rotate) then + call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") + ! if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + ! (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + + ! allocate(forces) + ! call allocate_mech_forcing(forces_in, CS%Grid, forces) + ! call rotate_mech_forcing(forces_in, CS%turns, forces) + ! else + ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + + ! forces=>forces_in endif G=>CS%Grid @@ -911,10 +916,10 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external scalar_pair=.true.) endif - if (CS%rotate_index .and. rotate) then - call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! TODO: deallocate mech forcing? - endif + ! if (CS%rotate_index .and. rotate) then + ! call rotate_mech_forcing(forces, -CS%turns, forces_in) + ! ! TODO: deallocate mech forcing? + ! endif end subroutine add_shelf_forces @@ -923,8 +928,7 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. - type(forcing), pointer :: fluxes !< A structure of surface fluxes that may be updated. - + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. type(ocean_grid_type), pointer :: G => NULL() ! A pointer to ocean's grid structure. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -957,7 +961,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) 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), pointer :: fluxes !< A structure of surface fluxes that may be used/updated. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. @@ -1305,7 +1309,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! Convenience pointers OG => CS%ocn_grid US => CS%US - !CS%diag=>diag ! Are we being called from the solo ice-sheet driver? When called by the ocean ! model solo_ice_sheet_in is not preset. From 8087f9300e4728bd3cb90f883ce69aa870bfbf1f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 21 Dec 2020 13:56:16 -0500 Subject: [PATCH 085/212] Return early from ice shelf initialization to avoid registering diagnostics and restarts during the call from initialize_MOM --- src/ice_shelf/MOM_ice_shelf.F90 | 244 +++++++++++++++++--------------- 1 file changed, 129 insertions(+), 115 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3638652bfc..15326b85ec 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1212,7 +1212,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, type(forcing), pointer :: fluxes => NULL() type(surface), pointer :: sfc_state => NULL() type(vardesc) :: u_desc, v_desc - + logical :: complete_initialization ! A flag which is set to true if forces are present + ! This exists for legacy reasons and is a means to avoid some + ! parts of the initilization procedure since the ice shelf + ! is being initialized twice from initialize MOM and from the + ! various driver routines. if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1220,6 +1224,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif allocate(CS) + complete_initialization=.false. + if (present(forces_in)) complete_initialization = .true. ! Go through all of the infrastructure initialization calls, since this is ! being treated as an independent component that just happens to use the ! MOM's grid and infrastructure. @@ -1245,57 +1251,59 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, !allocate(CS%Grid_in) call MOM_domains_init(CS%Grid_in%domain, 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_in%Domain, CS%Grid_in%HI, param_file, & local_indexing=.not.global_indexing) call MOM_grid_init(CS%Grid_in, param_file, CS%US, CS%Grid_in%HI) - if (CS%rotate_index) then - ! TODO: Index rotation currently only works when index rotation does not - ! change the MPI rank of each domain. Resolving this will require a - ! modification to FMS PE assignment. - ! For now, we only permit single-core runs. - - if (num_PEs() /= 1) & - call MOM_error(FATAL, "Index rotation is only supported on one PE.") - - call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & - "Number of counterclockwise quarter-turn index rotations.", & - default=1, debuggingParam=.true.) - ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. - ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. - allocate(CS%Grid) - !allocate(CS%HI) - call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) - call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) - call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) - call create_dyn_horgrid(dG, CS%Grid%HI) - call create_dyn_horgrid(dG_in, CS%Grid_in%HI) - call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) - ! Set up the bottom depth, G%D either analytically or from file - call set_grid_metrics(dG_in,param_file,CS%US) - call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) - call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) - call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) - call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - else - CS%Grid=>CS%Grid_in - !CS%Grid%HI=>CS%Grid_in%HI - call create_dyn_horgrid(dG, CS%Grid%HI) - call clone_MOM_domain(CS%Grid%Domain,dG%Domain) - call set_grid_metrics(dG,param_file,CS%US) - ! Set up the bottom depth, G%D either analytically or from file - call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file) - call rescale_dyn_horgrid_bathymetry(dG, CS%US%Z_to_m) - call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - endif + ! if (CS%rotate_index) then + ! ! TODO: Index rotation currently only works when index rotation does not + ! ! change the MPI rank of each domain. Resolving this will require a + ! ! modification to FMS PE assignment. + ! ! For now, we only permit single-core runs. + + ! if (num_PEs() /= 1) & + ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + ! "Number of counterclockwise quarter-turn index rotations.", & + ! default=1, debuggingParam=.true.) + ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + ! allocate(CS%Grid) + ! !allocate(CS%HI) + ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) + ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) + ! call create_dyn_horgrid(dG, CS%Grid%HI) + ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + ! ! Set up the bottom depth, G%D either analytically or from file + ! call set_grid_metrics(dG_in,param_file,CS%US) + ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) + ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) + ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) + ! else + CS%Grid=>CS%Grid_in + dG=>NULL() + !CS%Grid%HI=>CS%Grid_in%HI + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain,dG%Domain) + call set_grid_metrics(dG,param_file,CS%US) + ! Set up the bottom depth, G%D either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file) + call rescale_dyn_horgrid_bathymetry(dG, CS%US%Z_to_m) + call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) +! endif G=>CS%Grid - allocate(CS%diag) - call diag_mediator_init(G, param_file,CS%diag,component='MOM_IceShelf') - ! This call sets up the diagnostic axes. These are needed, - ! e.g. to generate the target grids below. - call set_axes_info(G, param_file, CS%diag) + if (complete_initialization) then + allocate(CS%diag) + call diag_mediator_init(G, param_file,CS%diag,component='MOM_IceShelf') + ! This call sets up the diagnostic axes. These are needed, + ! e.g. to generate the target grids below. + call set_axes_info(G, param_file, CS%diag) + endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1490,31 +1498,33 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif - call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 - - if (read_TIDEAMP) then - call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & + if (complete_initialization) then + call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 + 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.", & default="tideamp.nc") - 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));tmp2d(:,:)=0.0 - call MOM_read_data(TideAmp_file, 'tideamp', tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) - call rotate_array(tmp2d,CS%turns, CS%utide) - deallocate(tmp2d) + 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));tmp2d(:,:)=0.0 + call MOM_read_data(TideAmp_file, 'tideamp', 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) + endif else - call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) - endif - else - call get_param(param_file, mdl, "UTIDE", utide, & + call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0 , scale=US%m_s_to_L_T) - CS%utide(:,:) = utide + CS%utide(:,:) = utide + endif endif + call EOS_init(param_file, CS%eqn_of_state) !! new parameters that need to be in MOM_input @@ -1606,51 +1616,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif endif - ! Set up the restarts. - call restart_init(param_file, CS%restart_CSp, "Shelf.res") - call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & - "Ice shelf mass", "kg m-2") - call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") - call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") - if (PRESENT(sfc_state_in)) then - if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & - hor_grid='Cu',z_grid='1') - v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & - hor_grid='Cv',z_grid='1') - call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc,v_desc, & - .false., CS%restart_CSp) - endif - endif - - call register_restart_field(ISS%h_shelf, "_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") - 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") - endif - - if (CS%active_shelf_dynamics) then - ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics - call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) - endif - - !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") - !endif - - CS%restart_output_dir = dirs%restart_output_dir - new_sim = .false. if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. @@ -1740,12 +1705,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif ! .not. new_sim -! do j=G%jsc,G%jec ; do i=G%isc,G%iec -! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) -! enddo; enddo - - CS%Time = Time - id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) @@ -1757,7 +1716,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call pass_var(G%bathyT, G%domain) call cpu_clock_end(id_clock_pass) - do j=jsd,jed ; do i=isd,ied if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") @@ -1773,6 +1731,62 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) endif + + if (.not. complete_initialization) return + + ! Set up the restarts. + + call restart_init(param_file, CS%restart_CSp, "Shelf.res") + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + if (PRESENT(sfc_state_in)) then + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc,v_desc, & + .false., CS%restart_CSp) + endif + endif + + call register_restart_field(ISS%h_shelf, "_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + 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") + endif + + if (CS%active_shelf_dynamics) then + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) + endif + + !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") + !endif + + CS%restart_output_dir = dirs%restart_output_dir + + +! do j=G%jsc,G%jec ; do i=G%isc,G%iec +! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) +! enddo; enddo + + CS%Time = Time + if (present(forces_in)) & call add_shelf_forces(G, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) From 55c6eaa5721e2b18de060a6702276918d1fa86b9 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 21 Dec 2020 15:20:18 -0500 Subject: [PATCH 086/212] Modifications for coupled driver --- config_src/coupled_driver/ocean_model_MOM.F90 | 16 ++++++++-------- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 774201ddb5..b210cd4f81 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -182,13 +182,13 @@ module ocean_model_mod !! processes before time stepping the dynamics. type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing), pointer :: forces => NULL() !< A structure with the driving mechanical surface forces - type(forcing), pointer :: fluxes => NULL() !< A structure containing pointers to + type(mech_forcing) :: forces => NULL() !< A structure with the driving mechanical surface forces + type(forcing) :: fluxes => NULL() !< A structure containing pointers to !! the thermodynamic ocean forcing fields. - type(forcing), pointer :: flux_tmp => NULL() !< A secondary structure containing pointers to the + type(forcing) :: flux_tmp => NULL() !< A secondary structure containing pointers to the !! ocean forcing fields for when multiple coupled !! timesteps are taken per thermodynamic step. - type(surface), pointer :: sfc_state => NULL() !< A structure containing pointers to + type(surface) :: sfc_state => NULL() !< A structure containing pointers to !! the ocean surface state fields. type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics @@ -273,9 +273,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas endif allocate(OS) - allocate(OS%fluxes) - allocate(OS%forces) - allocate(OS%flux_tmp) +! allocate(OS%fluxes) +! allocate(OS%forces) +! allocate(OS%flux_tmp) OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return @@ -379,7 +379,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag_IS, OS%forces, OS%fluxes) + OS%diag, 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/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 15326b85ec..236e0b2b34 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1207,7 +1207,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting ! does not occur [Z ~> m] real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data - type(mech_forcing), pointer :: forces => NULL() type(forcing), pointer :: fluxes => NULL() type(surface), pointer :: sfc_state => NULL() @@ -1294,6 +1293,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file) call rescale_dyn_horgrid_bathymetry(dG, CS%US%Z_to_m) call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) + call destroy_dyn_horgrid(dG) ! endif G=>CS%Grid From 19c1a6af2b3afabf32879b5ee6f855092cd9b4cb Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 21 Dec 2020 16:31:29 -0500 Subject: [PATCH 087/212] fix compile issues --- config_src/coupled_driver/ocean_model_MOM.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index b210cd4f81..500c8ba0a2 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -182,13 +182,13 @@ module ocean_model_mod !! processes before time stepping the dynamics. type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing) :: forces => NULL() !< A structure with the driving mechanical surface forces - type(forcing) :: fluxes => NULL() !< A structure containing pointers to + type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces + type(forcing) :: fluxes !< A structure containing pointers to !! the thermodynamic ocean forcing fields. - type(forcing) :: flux_tmp => NULL() !< A secondary structure containing pointers to the + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the !! ocean forcing fields for when multiple coupled !! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state => NULL() !< A structure containing pointers to + type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics @@ -365,7 +365,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas use_melt_pot=.false. endif - allocate(OS%sfc_state) + !allocate(OS%sfc_state) 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) From bdcb8588a38dc13276c30357b5941dfd8813a53c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 22 Dec 2020 12:22:00 -0500 Subject: [PATCH 088/212] Move call to end ice shelf diag mediator into ice_shelf_end - retains original drivers --- config_src/coupled_driver/ocean_model_MOM.F90 | 6 ---- config_src/solo_driver/MOM_driver.F90 | 4 --- src/ice_shelf/MOM_ice_shelf.F90 | 2 ++ src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 29 +++++++++++++------ 4 files changed, 22 insertions(+), 19 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 500c8ba0a2..c4bd543bfd 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -48,7 +48,6 @@ module ocean_model_mod use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use MOM_IS_diag_mediator, only : diag_IS_ctrl => diag_ctrl, diag_mediator_IS_end=>diag_mediator_end use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -217,9 +216,6 @@ module ocean_model_mod !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure - type(diag_IS_ctrl), pointer :: & - diag_IS => NULL() !< A pointer to the diagnostic regulatory structure - !! for the ice shelf module. end type ocean_state_type contains @@ -728,8 +724,6 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag) - if (Ocean_state%use_ice_shelf) & - call diag_mediator_IS_end(Time, Ocean_state%diag_IS) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) end subroutine ocean_model_end diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index d61d6c986a..d36d86c8db 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -28,7 +28,6 @@ program MOM_main use MOM_cpu_clock, only : CLOCK_COMPONENT 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_IS_diag_mediator, only : diag_IS_ctrl=>diag_ctrl, diag_mediator_IS_end=>diag_mediator_end 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 @@ -199,8 +198,6 @@ program MOM_main !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure - type(diag_IS_ctrl), pointer :: & - diag_IS => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' @@ -665,7 +662,6 @@ program MOM_main call callTree_waypoint("End MOM_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) - if (use_ice_shelf) call diag_mediator_IS_end(Time, diag_IS) if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 236e0b2b34..7d5b7aeedf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -15,6 +15,7 @@ module MOM_ice_shelf use MOM_IS_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid, diag_ctrl, time_type use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_IS_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_close_registration +use MOM_IS_diag_mediator, only : diag_mediator_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -2059,6 +2060,7 @@ subroutine ice_shelf_end(CS) if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) + call diag_mediator_end(CS%diag) deallocate(CS) end subroutine ice_shelf_end diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index ab4245bd83..74d9ed701b 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -304,28 +304,41 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) used = send_data(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, mask=mask) elseif(i_data .and. associated(diag%mask2d)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d) used = send_data(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d_comp) used = send_data(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d_comp) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) else used = send_data(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (present(mask)) then +! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & +! weight=diag_cs%time_int, mask=mask) used = send_data(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, mask=mask) + weight=diag_cs%time_int) elseif(i_data .and. associated(diag%mask2d)) then +! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & +! weight=diag_cs%time_int, rmask=diag%mask2d) used = send_data(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%mask2d) + weight=diag_cs%time_int) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then +! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & +! weight=diag_cs%time_int, rmask=diag%mask2d_comp) used = send_data(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%mask2d_comp) + weight=diag_cs%time_int) else used = send_data(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -483,7 +496,6 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & !Decide what mask to use based on the axes info if (primary_id > 0) then - !3d masks !2d masks if (axes%rank == 2) then diag%mask2d => null() ; diag%mask2d_comp => null() @@ -682,7 +694,7 @@ subroutine diag_masks_set(G, missing_value, diag_cs) type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output ! Local variables - integer :: i, j, k, NkIce, CatIce + integer :: i, j diag_cs%mask2dT => G%mask2dT @@ -711,8 +723,7 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration !> Deallocate memory associated with the MOM_IS diag mediator -subroutine diag_mediator_end(time, diag_CS) - type(time_type), intent(in) :: time !< The current model time +subroutine diag_mediator_end(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output if (diag_CS%doc_unit > -1) then From 44e80d59fdce0faa535fc636a8b9faa2fa381237 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 22 Dec 2020 13:03:21 -0500 Subject: [PATCH 089/212] remove rotation related changes in initialize_ice_shelf --- src/ice_shelf/MOM_ice_shelf.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 7d5b7aeedf..8e60d81ba7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -82,14 +82,14 @@ module MOM_ice_shelf ! Parameters type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves - type(ocean_grid_type) :: Grid_in !< un-rotated input grid metric + type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for !! incoming data which has not been rotated. type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. - type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model + type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model type(unit_scale_type), pointer :: & US => NULL() !< A structure containing various unit conversion factors type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid @@ -1248,12 +1248,12 @@ 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_in) - call MOM_domains_init(CS%Grid_in%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + allocate(CS%Grid) + call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in') - call hor_index_init(CS%Grid_in%Domain, CS%Grid_in%HI, param_file, & - local_indexing=.not.global_indexing) - call MOM_grid_init(CS%Grid_in, param_file, CS%US, CS%Grid_in%HI) + !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & + ! local_indexing=.not.global_indexing) + call MOM_grid_init(CS%Grid, param_file, CS%US) ! if (CS%rotate_index) then ! ! TODO: Index rotation currently only works when index rotation does not @@ -1284,7 +1284,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) ! else - CS%Grid=>CS%Grid_in + !CS%Grid=>CS%Grid_in dG=>NULL() !CS%Grid%HI=>CS%Grid_in%HI call create_dyn_horgrid(dG, CS%Grid%HI) @@ -1296,7 +1296,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) call destroy_dyn_horgrid(dG) ! endif - G=>CS%Grid + G=>CS%Grid;CS%Grid_in=>CS%Grid if (complete_initialization) then allocate(CS%diag) From 88c4102d64614b046754633cf31af52b1ca6fab8 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 22 Dec 2020 13:24:45 -0500 Subject: [PATCH 090/212] move complete_initialization return before diag chksums --- src/ice_shelf/MOM_ice_shelf.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8e60d81ba7..56461dbc3d 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1727,14 +1727,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (G%areaT(i,j)>0.) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) enddo ; enddo ; endif + if (.not. complete_initialization) return + + if (CS%debug) then call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) endif - if (.not. complete_initialization) return - ! Set up the restarts. call restart_init(param_file, CS%restart_CSp, "Shelf.res") From d2d047c5e5665b3a82ed30dd11a4d9512cdd37e7 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 22 Dec 2020 13:25:37 -0500 Subject: [PATCH 091/212] remove masking from ice shelf diagnostics --- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 74d9ed701b..5db9646dae 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -319,12 +319,12 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) endif elseif (diag_cs%ave_enabled) then if (present(mask)) then -! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & -! weight=diag_cs%time_int, mask=mask) used = send_data(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + weight=diag_cs%time_int, mask=mask) +! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & +! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & +! weight=diag_cs%time_int) elseif(i_data .and. associated(diag%mask2d)) then ! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & From a1167461becebf56822d8c7ca08750e789058c4d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 29 Dec 2020 15:15:03 -0500 Subject: [PATCH 092/212] +Added initialize_ice_shelf_fluxes Added the routines initialize_ice_shelf_fluxes and initialize_ice_shelf_forces which call be called from within initialize_ice_shelf or separately, which removes the need to call initialize_ice_shelf multiple times. Also added the new runtime parameters USTAR_SHELF_FROM_VEL and USTAR_SHELF_MAX, which will enable the previous answers for the ISOMIP test cases to be recovered and will facilitate the debugging or control of poorly understood instabilities related to the dynamic or lagged calculation of ustar_shelf. All answers in the usual MOM6-examples test cases are bitwise identical, and the ISOMIP test cases are working once again. --- config_src/solo_driver/MOM_driver.F90 | 20 +- src/ice_shelf/MOM_ice_shelf.F90 | 259 ++++++++++++++------------ 2 files changed, 146 insertions(+), 133 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index d36d86c8db..9726aa1281 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -70,6 +70,7 @@ program MOM_main use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS 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_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves @@ -308,27 +309,24 @@ program MOM_main if (sum(date) >= 0) then call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_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) + diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp) else call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & - tracer_flow_CSp=tracer_flow_CSp,ice_shelf_CSp=ice_shelf_CSp) + tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp) endif - call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) + call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) + Master_Time = Time + use_ice_shelf = associated(ice_shelf_CSp) if (use_ice_shelf) then ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf - ice_shelf_CSp => NULL() ! Reset the pointer and make another call to reinitialize - ! the ice shelf and associated forcing types - call initialize_ice_shelf(param_file, grid, Time, ice_shelf_CSp, & - diag, forces, fluxes, sfc_state) + call initialize_ice_shelf_fluxes(ice_shelf_CSp, grid, US, fluxes) + call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) endif - call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) - Master_Time = Time call callTree_waypoint("done initialize_MOM") @@ -661,6 +659,7 @@ program MOM_main endif call callTree_waypoint("End MOM_main") + if (use_ice_shelf) 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) @@ -668,6 +667,5 @@ program MOM_main call io_infra_end ; call MOM_infra_end call MOM_end(MOM_CSp) - if (use_ice_shelf) call ice_shelf_end(ice_shelf_CSp) end program MOM_main diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 56461dbc3d..9592d17b03 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -11,11 +11,10 @@ module MOM_ice_shelf use MOM_coms, only : num_PEs use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl use MOM_IS_diag_mediator, only : post_data, register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr -use MOM_IS_diag_mediator, only : set_axes_info -use MOM_IS_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid, diag_ctrl, time_type +use MOM_IS_diag_mediator, only : set_axes_info, diag_ctrl, time_type +use MOM_IS_diag_mediator, only : diag_mediator_init, diag_mediator_end, set_diag_mediator_grid use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_IS_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_close_registration -use MOM_IS_diag_mediator, only : diag_mediator_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -71,6 +70,7 @@ module MOM_ice_shelf public shelf_calc_flux, initialize_ice_shelf, ice_shelf_end, ice_shelf_query public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces +public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces ! 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 @@ -82,14 +82,14 @@ module MOM_ice_shelf ! Parameters type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves - type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric + type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for !! incoming data which has not been rotated. type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. - type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model + type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model type(unit_scale_type), pointer :: & US => NULL() !< A structure containing various unit conversion factors type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid @@ -105,6 +105,8 @@ module MOM_ice_shelf utide => NULL() !< An unresolved tidal velocity [L T-1 ~> m s-1] real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. + real :: ustar_max !< A maximum value for ustar under ice shelves, or a negative value to + !! have no limit [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. @@ -126,6 +128,8 @@ module MOM_ice_shelf real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting !! does not occur [R Z ~> kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt + logical :: ustar_shelf_from_vel !< If true, use the surface velocities, and not the previous + !! values of the stresses to set ustar. !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! @@ -388,9 +392,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av - if (taux2 + tauy2 > 0.0) then - fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & - sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2)) + if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then + if (CS%ustar_max >= 0.0) then + fluxes%ustar_shelf(i,j) = MIN(CS%ustar_max, MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2))) + else + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2)) + endif else ! Take care of the cases when taux_shelf is not set or not allocated. fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & sqrt(CS%cdrag*((u2_av + v2_av) + CS%utide(i,j)**2))) @@ -819,7 +828,7 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca !! is using the input grid metric and needs !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. -! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces +! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -833,14 +842,10 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") if (CS%rotate_index .and. rotate) then call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") - ! if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - ! (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") - ! allocate(forces) ! call allocate_mech_forcing(forces_in, CS%Grid, forces) ! call rotate_mech_forcing(forces_in, CS%turns, forces) @@ -929,7 +934,8 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. - type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to ocean's grid structure. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -1162,8 +1168,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS + !! which will be discarded 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 @@ -1208,15 +1214,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting ! does not occur [Z ~> m] real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + type(mech_forcing), pointer :: forces => NULL() type(forcing), pointer :: fluxes => NULL() type(surface), pointer :: sfc_state => NULL() type(vardesc) :: u_desc, v_desc - logical :: complete_initialization ! A flag which is set to true if forces are present - ! This exists for legacy reasons and is a means to avoid some - ! parts of the initilization procedure since the ice shelf - ! is being initialized twice from initialize MOM and from the - ! various driver routines. + if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1224,8 +1227,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif allocate(CS) - complete_initialization=.false. - if (present(forces_in)) complete_initialization = .true. ! Go through all of the infrastructure initialization calls, since this is ! being treated as an independent component that just happens to use the ! MOM's grid and infrastructure. @@ -1251,6 +1252,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, allocate(CS%Grid) call MOM_domains_init(CS%Grid%domain, 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, & ! local_indexing=.not.global_indexing) call MOM_grid_init(CS%Grid, param_file, CS%US) @@ -1285,7 +1287,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) ! else !CS%Grid=>CS%Grid_in - dG=>NULL() + dG => NULL() !CS%Grid%HI=>CS%Grid_in%HI call create_dyn_horgrid(dG, CS%Grid%HI) call clone_MOM_domain(CS%Grid%Domain,dG%Domain) @@ -1296,15 +1298,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) call destroy_dyn_horgrid(dG) ! endif - G=>CS%Grid;CS%Grid_in=>CS%Grid - - if (complete_initialization) then - allocate(CS%diag) - call diag_mediator_init(G, param_file,CS%diag,component='MOM_IceShelf') - ! This call sets up the diagnostic axes. These are needed, - ! e.g. to generate the target grids below. - call set_axes_info(G, param_file, CS%diag) - endif + G => CS%Grid ; CS%Grid_in => CS%Grid + + allocate(CS%diag) + call diag_mediator_init(G, param_file, CS%diag, component='MOM_IceShelf') + ! This call sets up the diagnostic axes. These are needed, + ! e.g. to generate the target grids below. + call set_axes_info(G, param_file, CS%diag) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1499,33 +1499,30 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif - if (complete_initialization) then - call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 - if (read_TIDEAMP) then - call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & + call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 + 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.", & default="tideamp.nc") - 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));tmp2d(:,:)=0.0 - call MOM_read_data(TideAmp_file, 'tideamp', 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) - endif + 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));tmp2d(:,:)=0.0 + call MOM_read_data(TideAmp_file, 'tideamp', 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 get_param(param_file, mdl, "UTIDE", utide, & + call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) + endif + else + call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0 , scale=US%m_s_to_L_T) - CS%utide(:,:) = utide - endif + CS%utide(:,:) = utide endif - call EOS_init(param_file, CS%eqn_of_state) !! new parameters that need to be in MOM_input @@ -1565,58 +1562,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "velocity magnitude.", units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) if (CS%cdrag*drag_bg_vel > 0.0) CS%ustar_bg = sqrt(CS%cdrag)*drag_bg_vel endif + call get_param(param_file, mdl, "USTAR_SHELF_FROM_VEL", CS%ustar_shelf_from_vel, & + "If true, use the surface velocities to set the friction velocity under ice "//& + "shelves instead of using the previous values of the stresses.", & + default=.true.) + call get_param(param_file, mdl, "USTAR_SHELF_MAX", CS%ustar_max, & + "The maximum value of ustar under ice shelves, or a negative value for no limit.", & + units="m s-1", default=-1.0, scale=US%m_to_Z*US%T_to_s, & + do_not_log=CS%ustar_shelf_from_vel) ! Allocate and initialize state variables to default values call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS - ! Allocate the arrays for passing ice-shelf data through the forcing type. - if (.not. CS%solo_ice_sheet) then - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") - ! GMM: the following assures that water/heat fluxes are just allocated - ! when SHELF_THERMO = True. These fluxes are necessary if one wants to - ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). - if (present(fluxes_in)) then - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo) - if (CS%rotate_index) then - allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) - call rotate_forcing(fluxes_in, fluxes, CS%turns) - else - fluxes=>fluxes_in - endif - endif - if (present(forces_in)) then - call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true.) - if (CS%rotate_index) then - allocate(forces) - call allocate_mech_forcing(forces_in, CS%Grid, forces) - call rotate_mech_forcing(forces_in, CS%turns, forces) - else - forces=>forces_in - endif - endif - else - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - if (present(fluxes_in)) then - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true.) - if (CS%rotate_index) then - allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) - call rotate_forcing(fluxes_in, fluxes, CS%turns) - endif - endif - if (present(forces_in)) then - call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true.) - if (CS%rotate_index) then - allocate(forces) - call allocate_mech_forcing(forces_in, CS%Grid, forces) - call rotate_mech_forcing(forces_in, CS%turns, forces) - endif - endif - endif - new_sim = .false. if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. @@ -1706,6 +1664,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif ! .not. new_sim +! do j=G%jsc,G%jec ; do i=G%isc,G%iec +! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) +! enddo; enddo + id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) @@ -1723,15 +1685,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ISS%area_shelf_h(i,j) = G%areaT(i,j) endif enddo ; enddo - if (present(fluxes_in)) then ; do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j)>0.) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo ; endif - - if (.not. complete_initialization) return - if (CS%debug) then - call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) endif @@ -1782,17 +1737,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%restart_output_dir = dirs%restart_output_dir - -! do j=G%jsc,G%jec ; do i=G%isc,G%iec -! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) -! enddo; enddo - CS%Time = Time - if (present(forces_in)) & - call add_shelf_forces(G, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) - - if (present(fluxes_in)) call add_shelf_pressure(ocn_grid, US, CS, fluxes) if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then ISS%water_flux(:,:) = 0.0 @@ -1860,14 +1806,83 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif call diag_mediator_close_registration(CS%diag) - - if (present(fluxes_in) .and. CS%rotate_index) & - call rotate_forcing(fluxes, fluxes_in, -CS%turns) - if (present(forces_in) .and. CS%rotate_index) & - call rotate_mech_forcing(forces, -CS%turns, forces_in) + if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) + if (present(forces_in)) call initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) end subroutine initialize_ice_shelf +subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + + ! Local variables + type(ocean_grid_type), pointer :: G => NULL() ! Pointers to grids for convenience. + type(forcing), pointer :: fluxes => NULL() + integer :: i, j, isd, ied, jsd, jed + + G => CS%Grid + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + ! Allocate the arrays for passing ice-shelf data through the forcing type. + if (.not. CS%solo_ice_sheet) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") + ! GMM: the following assures that water/heat fluxes are just allocated + ! 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) + 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.) + endif + if (CS%rotate_index) then + allocate(fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call rotate_forcing(fluxes_in, fluxes, CS%turns) + else + fluxes=>fluxes_in + endif + + do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j)>0.) fluxes%frac_shelf_h(i,j) = CS%ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo + if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) + call add_shelf_pressure(ocn_grid, US, CS, fluxes) + + if (CS%rotate_index) & + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + +end subroutine initialize_ice_shelf_fluxes + +subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces + + ! Local variables + 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.) + if (CS%rotate_index) then + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + forces=>forces_in + endif + + call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + + if (CS%rotate_index) & + call rotate_mech_forcing(forces, -CS%turns, forces_in) + +end subroutine initialize_ice_shelf_forces + !> Initializes shelf mass based on three options (file, zero and user) subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) @@ -1952,7 +1967,7 @@ end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. subroutine update_shelf_mass(G, US, CS, ISS, Time) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated type(time_type), intent(in) :: Time !< The current model time From 464f39e06edddd2d54dd1af6f6cef67fd617aab1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 06:13:51 -0500 Subject: [PATCH 093/212] Remove extra register_restart call for ISS%h_shelf Removed the duplicate register_restart_field call for ISS%h_shelf under the name "_shelf". This registration call should have never been there in the first place. All answers are bitwise identical, although there are changes to the restart file contents in cases with an active ice shelf. --- src/ice_shelf/MOM_ice_shelf.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 9592d17b03..335db29ccb 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1711,8 +1711,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif endif - call register_restart_field(ISS%h_shelf, "_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") 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, & From 1e6bdd6a1788bdafa7842d66e47d7326e41764f1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 06:44:25 -0500 Subject: [PATCH 094/212] Remove unused module use statements Removed unused module use statements in various modules, to help eliminate apparent but inaccurate module dependencies, and to facilitate the migration to FMS2. All answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 2 +- src/core/MOM_dynamics_unsplit.F90 | 1 - src/core/MOM_dynamics_unsplit_RK2.F90 | 1 - src/framework/MOM_diag_remap.F90 | 1 - src/framework/MOM_horizontal_regridding.F90 | 11 ++++----- src/framework/MOM_transform_FMS.F90 | 2 +- .../MOM_tracer_initialization_from_Z.F90 | 24 ++++++------------- src/tracer/advection_test_tracer.F90 | 2 +- src/tracer/boundary_impulse_tracer.F90 | 5 ++-- src/tracer/dye_example.F90 | 2 +- src/tracer/pseudo_salt_tracer.F90 | 5 ++-- src/user/BFB_surface_forcing.F90 | 1 - src/user/ISOMIP_initialization.F90 | 4 +--- src/user/dumbbell_surface_forcing.F90 | 1 - src/user/user_revise_forcing.F90 | 2 +- 15 files changed, 21 insertions(+), 43 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 519f510239..4ea6734511 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -27,7 +27,7 @@ module MOM_dynamics_split_RK2 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 : MOM_io_init, vardesc, var_desc +use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 6b9aa8e759..30544b0193 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -68,7 +68,6 @@ module MOM_dynamics_unsplit 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_get_input, only : directories -use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS use MOM_time_manager, only : time_type, real_to_time, operator(+) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 4181ab519d..2f93561c3f 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -67,7 +67,6 @@ module MOM_dynamics_unsplit_RK2 use MOM_error_handler, only : MOM_set_verbosity use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories -use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS use MOM_time_manager, only : time_type, time_type_to_real, operator(+) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 4e12abaa5b..6d1fa7b6fa 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -80,7 +80,6 @@ module MOM_diag_remap use coord_sigma, only : build_sigma_column use coord_rho, only : build_rho_column -use diag_axis_mod, only : get_diag_axis_name use diag_manager_mod, only : diag_axis_init use MOM_debugging, only : check_column_integrals diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 66f58b5b9d..8af6129812 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -24,15 +24,12 @@ module MOM_horizontal_regridding use MOM_time_manager, only : get_external_field_axes, get_external_field_missing use MOM_transform_FMS, only : time_interp_external => rotated_time_interp_external use MOM_variables, only : thermo_var_ptrs -use mpp_io_mod, only : axistype -use mpp_domains_mod, only : mpp_global_field, mpp_get_compute_domain -use mpp_mod, only : mpp_broadcast,mpp_root_pe,mpp_sync,mpp_sync_self -use mpp_mod, only : mpp_max -use horiz_interp_mod, only : horiz_interp_new, horiz_interp,horiz_interp_type + +use mpp_io_mod, only : axistype, mpp_get_axis_data +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_max +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_type use horiz_interp_mod, only : horiz_interp_init, horiz_interp_del -use mpp_io_mod, only : mpp_get_axis_data -use mpp_io_mod, only : MPP_SINGLE use netcdf implicit none ; private diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 index 97e0be85f6..572a9717dc 100644 --- a/src/framework/MOM_transform_FMS.F90 +++ b/src/framework/MOM_transform_FMS.F90 @@ -7,7 +7,7 @@ module MOM_transform_FMS use MOM_error_handler, only : MOM_error, FATAL use MOM_io, only : fieldtype, write_field use mpp_domains_mod, only : domain2D -use fms_mod, only : mpp_chksum +use mpp_mod, only : mpp_chksum use time_manager_mod, only : time_type use time_interp_external_mod, only : time_interp_external diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 1a4c5bd011..12235ddd87 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -4,27 +4,17 @@ 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_coms, only : max_across_PEs, min_across_PEs 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_density_integrals, only : int_specific_vol_dp -use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast -use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +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, read_param, log_param, param_file_type -use MOM_file_parser, only : log_version -use MOM_get_input, only : directories -use MOM_grid, only : ocean_grid_type, isPointInCell +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_regridding, only : regridding_CS use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h -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, setVerticalGridAxes -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use MOM_verticalGrid, only : verticalGrid_type use MOM_ALE, only : ALE_remap_scalar implicit none ; private @@ -42,7 +32,7 @@ module MOM_tracer_initialization_from_Z contains -!> Initializes a tracer from a z-space data file. +!> 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 ) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index b1d657d6e2..3aa65e8b3c 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -9,7 +9,7 @@ module advection_test_tracer 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 : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index da76cb3026..fc85b5c3ec 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -9,7 +9,7 @@ module boundary_impulse_tracer 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 : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -18,8 +18,7 @@ module boundary_impulse_tracer use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use coupler_types_mod, only : coupler_type_set_data, ind_csurf diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index cd17415b21..8a970fa9ca 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -9,7 +9,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_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +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 use MOM_sponge, only : set_up_sponge_field, sponge_CS diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 95396a3b58..11238fee89 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -11,7 +11,7 @@ module pseudo_salt_tracer 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 : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +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 use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -20,8 +20,7 @@ module pseudo_salt_tracer use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use coupler_types_mod, only : coupler_type_set_data, ind_csurf diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index d06262b7cf..3963d4d90d 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -10,7 +10,6 @@ module BFB_surface_forcing use MOM_file_parser, only : get_param, param_file_type, log_version use MOM_forcing_type, only : forcing, allocate_forcing_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index d125495d7f..a0b8990e62 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -10,9 +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_io, only : file_exists -use MOM_io, only : MOM_read_data -use MOM_io, only : slasher +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 use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 4b5bf5a2fb..ea27d01cdc 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -10,7 +10,6 @@ module dumbbell_surface_forcing use MOM_file_parser, only : get_param, param_file_type, log_version use MOM_forcing_type, only : forcing, allocate_forcing_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/), get_time use MOM_tracer_flow_control, only : call_tracer_set_forcing diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index c53451f4e8..bf31ca02f8 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -8,7 +8,7 @@ module user_revise_forcing 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 : file_exists, read_data +use MOM_io, only : file_exists, MOM_read_data use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing From 9b0b8db88ad92a62b36afbd8005cab182e60fb77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 09:45:39 -0500 Subject: [PATCH 095/212] Use MOM framework routines in MOM_open_boundary Use MOM framework interfaces in MOM_open_boundary in place of direct calls to mpp routines, to facilitate the migration to FMS2. All answers are bitwise identical. --- src/core/MOM_open_boundary.F90 | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 46d144a8c6..0232ff91ff 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -5,13 +5,12 @@ module MOM_open_boundary use MOM_array_transform, only : rotate_array, rotate_array_pair use MOM_array_transform, only : allocate_rotated_array -use MOM_coms, only : sum_across_PEs +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_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, CORNER -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : NOTE +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 @@ -651,13 +650,11 @@ end subroutine open_boundary_config !> Allocate space for reading OBC data from files. It sets up the required vertical !! remapping. In the process, it does funky stuff with the MPI processes. subroutine initialize_segment_data(G, OBC, PF) - use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure - type(param_file_type), intent(in) :: PF !< Parameter file handle + type(ocean_OBC_type), 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 character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix @@ -697,11 +694,11 @@ subroutine initialize_segment_data(G, OBC, PF) !< temporarily disable communication in order to read segment data independently - allocate(saved_pelist(0:mpp_npes()-1)) - call mpp_get_current_pelist(saved_pelist) - current_pe = mpp_pe() + allocate(saved_pelist(0:num_PEs()-1)) + call Get_PElist(saved_pelist) + current_pe = PE_here() single_pelist(1) = current_pe - call mpp_set_current_pelist(single_pelist) + call Set_PElist(single_pelist) do n=1, OBC%number_of_segments segment => OBC%segment(n) @@ -955,7 +952,7 @@ subroutine initialize_segment_data(G, OBC, PF) endif enddo - call mpp_set_current_pelist(saved_pelist) + call Set_PElist(saved_pelist) end subroutine initialize_segment_data From 611132731dd731b7f2f4d26bcde2188b218fafef Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 09:46:01 -0500 Subject: [PATCH 096/212] Use MOM_read_data in RGC_initialization Use MOM_read_data in place of read_data in RGC_initialization to match the routines used in other modules and facilitate migration to FMS2. All answers are bitwise identical. --- src/user/RGC_initialization.F90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 70b9fcd4dc..1600aca5bd 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -28,8 +28,7 @@ module RGC_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_io, only : file_exists, read_data -use MOM_io, only : slasher +use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_sponge, only : set_up_sponge_ML_density use MOM_unit_scaling, only : unit_scale_type @@ -173,12 +172,12 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) filename = trim(inputdir)//trim(state_file) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " RGC_initialize_sponges: Unable to open "//trim(filename)) - call read_data(filename,temp_var,T(:,:,:), domain=G%Domain%mpp_domain) - call read_data(filename,salt_var,S(:,:,:), domain=G%Domain%mpp_domain) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) if (use_ALE) then - call read_data(filename,h_var,h(:,:,:), domain=G%Domain%mpp_domain) + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain) call pass_var(h, G%domain) !call initialize_ALE_sponge(Idamp, h, nz, G, PF, ACSp) @@ -201,7 +200,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) else ! layer mode !read eta - call read_data(filename,eta_var,eta(:,:,:), domain=G%Domain%mpp_domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) ! Set the inverse damping rates so that the model will know where to ! apply the sponges, along with the interface heights. From 0b019b66773b6b8589b68fe565193cab10e6307f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 09:58:00 -0500 Subject: [PATCH 097/212] Avoid using memory macros in MOM_random.F90 Expanded the SZI_ and SZJ_ macros in random_2d_ routines to eliminate any dependence on MOM_memory.h and facilitate the future compilation of MOM_random as a part of a MOM framework library. All answers are bitwise identical. --- src/framework/MOM_random.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 161236572c..21e3223a03 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -11,7 +11,7 @@ module MOM_random use MersenneTwister_mod, only : getRandomReal ! Generates a random number use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer -use MOM_io, only : stdout, stderr +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -23,8 +23,6 @@ module MOM_random public :: random_2d_norm public :: random_unit_tests -#include - !> Container for pseudo-random number generators type, public :: PRNG ; private @@ -63,7 +61,7 @@ end function random_norm subroutine random_2d_01(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(SZI_(HI),SZJ_(HI)), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 ! Local variables integer :: i,j @@ -80,7 +78,7 @@ end subroutine random_2d_01 subroutine random_2d_norm(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(SZI_(HI),SZJ_(HI)), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 ! Local variables integer :: i,j,n From aed5a680babcf4123c79df1fb4dd4758dbd79ef8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 10:28:46 -0500 Subject: [PATCH 098/212] +Add the new routine read_field_chksum to MOM_io Added the new routine read_field_chksum to MOM_io.F90, so that all calls to the FMS i/o layer can be directed via MOM_io.F90, in order to facilitate the painless and compartmentalized migration to FMS2. Also added a 0-d variant for MOM_read_data, and standardized the control-flag and subroutine aliases used in MOM_io.F90. All answers are bitwise identical, but there are new public interfaces. --- src/framework/MOM_io.F90 | 78 +++++++++++++++++++++++++++++----------- 1 file changed, 57 insertions(+), 21 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index d13dddc3c7..529c725274 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -16,19 +16,19 @@ module MOM_io use ensemble_manager_mod, only : get_ensemble_id use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_size, read_data -use fms_io_mod, only : field_exists => field_exist, io_infra_end=>fms_io_exit -use fms_io_mod, only : get_filename_appendix => get_filename_appendix +use fms_io_mod, only : field_exists=>field_exist, io_infra_end=>fms_io_exit +use fms_io_mod, only : get_filename_appendix=>get_filename_appendix use mpp_domains_mod, only : domain1d, domain2d, mpp_get_domain_components use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST use mpp_io_mod, only : open_file => mpp_open, close_file => mpp_close -use mpp_io_mod, only : mpp_write_meta, write_field => mpp_write, mpp_get_info -use mpp_io_mod, only : mpp_get_atts, mpp_get_axes, get_axis_data=>mpp_get_axis_data, axistype -use mpp_io_mod, only : mpp_get_fields, fieldtype, axistype, flush_file => mpp_flush +use mpp_io_mod, only : mpp_write_meta, write_field => mpp_write +use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist +use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data +use mpp_io_mod, only : mpp_get_fields, fieldtype, flush_file=>mpp_flush use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY use mpp_io_mod, only : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY -use mpp_io_mod, only : MPP_APPEND, MPP_MULTI, MPP_OVERWR, MPP_NETCDF, MPP_RDONLY use mpp_io_mod, only : get_file_info=>mpp_get_info, get_file_atts=>mpp_get_atts use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times use mpp_io_mod, only : io_infra_init=>mpp_io_init @@ -40,7 +40,7 @@ module MOM_io public :: close_file, create_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields -public :: get_file_times, open_file, read_axis_data, read_data +public :: get_file_times, open_file, read_axis_data, read_data, read_field_chksum public :: num_timelevels, MOM_read_data, MOM_read_vector, ensembler public :: reopen_file, slasher, write_field, write_version_number, MOM_io_init public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end @@ -77,6 +77,7 @@ module MOM_io module procedure MOM_read_data_3d module procedure MOM_read_data_2d module procedure MOM_read_data_1d + module procedure MOM_read_data_0d end interface !> Read a pair of data fields representing the two components of a vector from a file @@ -162,9 +163,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(unit, filename, MPP_OVERWR, MPP_NETCDF, threading=thread) + call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, threading=thread) else - call open_file(unit, filename, MPP_OVERWR, MPP_NETCDF, domain=Domain%mpp_domain) + call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, domain=Domain%mpp_domain) endif ! Define the coordinates. @@ -404,13 +405,13 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(unit, filename, MPP_APPEND, MPP_NETCDF, threading=thread) + call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, threading=thread) else - call open_file(unit, filename, MPP_APPEND, MPP_NETCDF, domain=Domain%mpp_domain) + call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, domain=Domain%mpp_domain) endif if (unit < 0) return - call mpp_get_info(unit, ndim, nvar, natt, ntime) + call get_file_info(unit, ndim, nvar, natt, ntime) if (nvar == -1) then write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& @@ -449,11 +450,11 @@ subroutine read_axis_data(filename, axis_name, var) type(axistype) :: time_axis character(len=32) :: name, units - call open_file(unit, trim(filename), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=SINGLE_FILE) + call open_file(unit, trim(filename), action=READONLY_FILE, form=NETCDF_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !Find the number of variables (nvar) in this file - call mpp_get_info(unit, ndim, nvar, natt, ntime) + call get_file_info(unit, ndim, nvar, natt, ntime) ! ------------------------------------------------------------------- ! Allocate space for the number of axes in the data file. ! ------------------------------------------------------------------- @@ -462,7 +463,7 @@ subroutine read_axis_data(filename, axis_name, var) axis_found = .false. do i = 1, ndim - call mpp_get_atts(axes(i), name=name,len=len,units=units) + call get_file_atts(axes(i), name=name, len=len, units=units) if (name == axis_name) then axis_found = .true. call get_axis_data(axes(i),var) @@ -477,6 +478,23 @@ subroutine read_axis_data(filename, axis_name, var) end subroutine read_axis_data +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=8), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + ! Local variables + integer(kind=8), dimension(3) :: checksum_file + + checksum_file(:) = -1 + valid_chksum = mpp_attribute_exist(field, "checksum") + if (valid_chksum) then + call mpp_get_atts(field, checksum=checksum_file) + chksum = checksum_file(1) + else + chksum = -1 + endif +end subroutine read_field_chksum + !> This function determines how many time levels a variable has. function num_timelevels(filename, varname, min_dims) result(n_time) character(len=*), intent(in) :: filename !< name of the file to read @@ -519,7 +537,6 @@ function num_timelevels(filename, varname, min_dims) result(n_time) return endif - allocate(varids(nvars)) status = nf90_inq_varids(ncid, nvars, varids) @@ -848,7 +865,26 @@ function FMS_file_exists(filename, domain, no_domain) end function FMS_file_exists -!> This function uses the fms_io function read_data to read 1-D + +!> This function uses the fms_io function read_data to read a scalar +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, 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, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif + +end subroutine MOM_read_data_0d + +!> This function uses the fms_io function read_data to read a 1-D !! data field named "fieldname" from file "filename". subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) character(len=*), intent(in) :: filename !< The name of the file to read @@ -879,7 +915,7 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before they are returned. + !! by before it is returned. integer :: is, ie, js, je @@ -907,7 +943,7 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before they are returned. + !! by before it is returned. integer :: is, ie, js, je @@ -935,7 +971,7 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before they are returned. + !! by before it is returned. integer :: is, ie, js, je From aea16f7302d52fed890b8c4e79876029a4ebbb5c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 3 Jan 2021 11:43:23 -0500 Subject: [PATCH 099/212] Use read_field_chksum in MOM_restart Use read_field_chksum and MOM_read_data in MOM_restart. Also internally renamed mpp_chksum to just chksum in MOM_restart to aid in identifying unfiltered dependencies on FMS in MOM_restart.F90. All answers are bitwise identical. --- src/framework/MOM_restart.F90 | 71 +++++++++++++++-------------------- 1 file changed, 31 insertions(+), 40 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 7181a1f1b9..6e4e3d745b 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -3,24 +3,22 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_domains, only : pe_here, num_PEs +use MOM_domains, only : PE_here, num_PEs 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_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : MOM_read_data, read_data, get_filename_appendix +use MOM_io, only : MOM_read_data, read_data, get_filename_appendix, read_field_chksum use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE -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 -use MOM_transform_FMS, only : mpp_chksum => rotated_mpp_chksum +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 +use MOM_transform_FMS, only : chksum => rotated_mpp_chksum use MOM_transform_FMS, only : write_field => rotated_write_field -use MOM_verticalGrid, only : verticalGrid_type -use mpp_io_mod, only : mpp_attribute_exist, mpp_get_atts -use mpp_mod, only : mpp_pe +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -116,7 +114,7 @@ module MOM_restart module procedure register_restart_field_ptr0d, register_restart_field_0d end interface -!> Register a pair of restart fieilds whose rotations map onto each other +!> Register a pair of restart fields whose rotations map onto each other interface register_restart_pair module procedure register_restart_pair_ptr2d module procedure register_restart_pair_ptr3d @@ -1010,18 +1008,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then - check_val(m-start_var+1,1) = & - mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - check_val(m-start_var+1,1) = & - mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - check_val(m-start_var+1,1) = & - mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) + check_val(m-start_var+1,1) = chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p,pelist=(/mpp_pe()/)) + check_val(m-start_var+1,1) = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) endif enddo @@ -1100,9 +1095,9 @@ subroutine restore_state(filename, directory, day, G, CS) real :: t1, t2 ! Two times. real, allocatable :: time_vals(:) type(fieldtype), allocatable :: fields(:) - logical :: check_exist, is_there_a_checksum - integer(kind=8),dimension(3) :: checksum_file - integer(kind=8) :: checksum_data + 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. if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") @@ -1202,25 +1197,21 @@ subroutine restore_state(filename, directory, day, G, CS) do i=1, nvar call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then - check_exist = mpp_attribute_exist(fields(i),"checksum") - checksum_file(:) = -1 checksum_data = -1 - is_there_a_checksum = .false. - if ( check_exist ) then - call mpp_get_atts(fields(i),checksum=checksum_file) - is_there_a_checksum = .true. + if (CS%checksum_required) then + call 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. endif - if (.NOT. CS%checksum_required) is_there_a_checksum = .false. ! Do not need to do data checksumming. if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. - call read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & - G%Domain%mpp_domain, timelevel=1) - if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr1d(m)%p) + call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, timelevel=1) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... - call read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & - G%Domain%mpp_domain, timelevel=1) - if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr0d(m)%p,pelist=(/mpp_pe()/)) + call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, timelevel=1) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & @@ -1229,7 +1220,7 @@ subroutine restore_state(filename, directory, day, G, CS) call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & @@ -1238,7 +1229,7 @@ subroutine restore_state(filename, directory, day, G, CS) call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) 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, & @@ -1247,14 +1238,14 @@ subroutine restore_state(filename, directory, day, G, CS) call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) else call MOM_error(FATAL, "MOM_restart restore_state: No pointers set for "//trim(varname)) endif - if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then + if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file /= checksum_data)) then write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& - " does not match value ", checksum_file(1), & + " does not match value ", checksum_file, & " stored in "//trim(unit_path(n)//"." ) call MOM_error(FATAL, "MOM_restart(restore_state): "//trim(mesg) ) endif @@ -1455,7 +1446,7 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & if (fexists) then if (present(units)) & call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & - threading = MULTIPLE, fileset = SINGLE_FILE) + threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(n) = .true. elseif (CS%parallel_restartfiles) then ! Look for decomposed files using the I/O Layout. @@ -1484,7 +1475,7 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & if (fexists) then if (present(units)) & call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & - threading = MULTIPLE, fileset = SINGLE_FILE) + threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(n) = .true. if (present(file_paths)) file_paths(n) = filepath n = n + 1 From 971802a7d9b41aee75407e729e3bb17dafdcc0fd Mon Sep 17 00:00:00 2001 From: jiandewang Date: Mon, 4 Jan 2021 10:39:29 -0500 Subject: [PATCH 100/212] revert back to GFDL main for coupled_driver codes --- .../MOM_surface_forcing_gfdl.F90 | 25 +------------------ config_src/coupled_driver/ocean_model_MOM.F90 | 2 +- 2 files changed, 2 insertions(+), 25 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 3c8f084b4a..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -189,12 +189,6 @@ module MOM_surface_forcing_gfdl !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model [m3 s-1] - real, pointer, dimension(:,:) :: ustk0 => NULL() !< - real, pointer, dimension(:,:) :: vstk0 => NULL() !< - real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< - real, pointer, dimension(:,:,:) :: ustkb => NULL() !< - real, pointer, dimension(:,:,:) :: vstkb => NULL() !< - integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields !! used for passive tracer fluxes. @@ -202,7 +196,6 @@ module MOM_surface_forcing_gfdl !! This flag may be set by the flux-exchange code, based on what !! the sea-ice model is providing. Otherwise, the value from !! the surface_forcing_CS is used. - integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler end type ice_ocean_boundary_type integer :: id_clock_forcing !< A CPU time clock @@ -684,7 +677,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ real :: mass_eff ! effective mass of sea ice for rigidity [R Z ~> kg m-2] real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -725,9 +718,6 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) - if ( associated(IOB%ustk0) ) & - call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) - if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -787,19 +777,6 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) enddo ; enddo endif - forces%stk_wavenumbers(:) = IOB%stk_wavenumbers - do j=js,je; do i=is,ie - forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? - forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) - enddo ; enddo - call pass_vector(forces%ustk0,forces%vstk0, G%domain ) - do istk = 1,IOB%num_stk_bands - do j=js,je; do i=is,ie - forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) - forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) - enddo; enddo - call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) - enddo ! Find the net mass source in the input forcing without other adjustments. if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 6cb358cdcb..082099158c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -565,7 +565,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! For now, the waves are only updated on the thermodynamics steps, because that is where ! the wave intensities are actually used to drive mixing. At some point, the wave updates ! might also need to become a part of the ocean dynamics, according to B. Reichl. - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. From 5c9b5fad7827c4c27b5b074fd508f82f82c532b4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Jan 2021 08:59:22 -0500 Subject: [PATCH 101/212] Corrected the statement setting use_ice_shelf Corrected the statement setting use_ice_shelf in initialize_MOM, which somehow was not merged in correctly, presumably due to human error, when dev/gfdl was merged into this branch. All answers are bitwise identical. --- src/core/MOM.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ec88548934..f11ce42407 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2036,7 +2036,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "state variables. Add USE_EOS = True to MOM_input.") use_ice_shelf = .false. - if (present(ice_shelf_CSp)) use_ice_shelf = associated(ice_shelf_CSp) + if (present(ice_shelf_CSp)) then + call get_param(param_file, "MOM", "ICE_SHELF", use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + endif CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & From 069760426d6e9ebc34c04f0ef89827849858fe28 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Jan 2021 14:50:25 -0500 Subject: [PATCH 102/212] Corrected an OMP directive Added GV to the shared declaration in an openMP directive. 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 92b8c9a2f0..6ebe162aab 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1392,7 +1392,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] real, intent(in) :: dt !< Time-step [s] @@ -1416,7 +1416,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then - !$OMP parallel do default(none) shared(dt, scalar, dtracer, G) + !$OMP parallel do default(none) shared(dt, scalar, dtracer, G, GV) do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec From 5f5871c1df3e95201292039e3247439f2ff48c17 Mon Sep 17 00:00:00 2001 From: "Jessica.Meixner" Date: Tue, 5 Jan 2021 20:20:02 +0000 Subject: [PATCH 103/212] Addressing reviewers comments: * document wave coupling variables * switch ii jj loops for computational efficiency * clarify error message * fix indexing and style --- .../mom_surface_forcing_nuopc.F90 | 14 +++-- src/core/MOM_forcing_type.F90 | 18 +++--- src/user/MOM_wave_interface.F90 | 60 +++++++++---------- 3 files changed, 50 insertions(+), 42 deletions(-) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 7b4e33a56a..585117c3ba 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -183,11 +183,15 @@ module MOM_surface_forcing_nuopc !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model in [m3/s] - real, pointer, dimension(:,:) :: ustk0 => NULL() !< - real, pointer, dimension(:,:) :: vstk0 => NULL() !< - real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< - real, pointer, dimension(:,:,:) :: ustkb => NULL() !< - real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + real, pointer, dimension(:,:) :: ustk0 => NULL() !< Surface Stokes drift, zonal [m/s] + real, pointer, dimension(:,:) :: vstk0 => NULL() !< Surface Stokes drift, meridional [m/s] + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad/m] + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< Stokes Drift spectrum, zonal [m/s] + !! Horizontal - u points + !! 3rd dimension - wavenumber + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< Stokes Drift spectrum, meridional [m/s] + !! Horizontal - v points + !! 3rd dimension - wavenumber integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 6720414b2b..a135107025 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -250,13 +250,17 @@ module MOM_forcing_type !! reset to zero at the driver level when appropriate. real, pointer, dimension(:,:) :: & - ustk0 => NULL(), & - vstk0 => NULL() + ustk0 => NULL(), & !< Surface Stokes drift, zonal [m/s] + vstk0 => NULL() !< Surface Stokes drift, meridional [m/s] real, pointer, dimension(:) :: & - stk_wavenumbers => NULL() + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad/m] real, pointer, dimension(:,:,:) :: & - ustkb => NULL(), & - vstkb => NULL() + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m/s] + !! Horizontal - u points + !! 3rd dimension - wavenumber + vstkb => NULL() !< Stokes Drift spectrum, meridional [m/s] + !! Horizontal - v points + !! 3rd dimension - wavenumber logical :: initialized = .false. !< This indicates whether the appropriate arrays have been initialized. end type mech_forcing @@ -3041,12 +3045,12 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & forces%stk_wavenumbers(:) = 0.0 allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) forces%ustkb(isd:ied,jsd:jed,:) = 0.0 - endif; endif; endif + endif ; endif ; endif if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands)) forces%vstkb(isd:ied,jsd:jed,:) = 0.0 - endif; endif; endif + endif ; endif ; endif end subroutine allocate_mech_forcing_by_group diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index e79f7b65ef..6352774fa7 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -467,10 +467,10 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) call Surface_Bands_by_data_override(day_center, G, GV, US, CS) elseif (DataSource==Coupler) then if (.not.present(FORCES)) then - call MOM_error(FATAL,"The code cannot be run with the options "//& - "SURFBAND_SOURCE = COUPLER for with this driver. If you are using a "//& - "wave coupled driver then check the call to update_surface_waves, otherwise"//& - "select another option for SURFBAND_SOURCE.") + call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& + "this driver. If you are using a coupled driver with a wave model then "//& + "check the arguments in the subroutine call to Update_Surface_Waves, "//& + "otherwise select another option for SURFBAND_SOURCE.") endif if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& @@ -481,13 +481,13 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) do b=1,CS%NumBands CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) !Interpolate from a grid to c grid - do II=G%iscB,G%iecB - do jj=G%jsc,G%jec + 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)) enddo enddo - do ii=G%isc,G%iec - do JJ=G%jscB, G%jecB + 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)) enddo enddo @@ -495,13 +495,13 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) enddo elseif (DataSource==Input) then do b=1,CS%NumBands - do II=G%isdB,G%iedB - do jj=G%jsd,G%jed + do jj=G%jsd,G%jed + do II=G%isdB,G%iedB CS%STKx0(II,jj,b) = CS%PrescribedSurfStkX(b) enddo enddo - do ii=G%isd,G%ied - do JJ=G%jsdB, G%jedB + do JJ=G%jsdB, G%jedB + do ii=G%isd,G%ied CS%STKY0(ii,JJ,b) = CS%PrescribedSurfStkY(b) enddo enddo @@ -537,8 +537,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! Computing mid-point value from surface value and decay wavelength if (WaveMethod==TESTPROF) then DecayScale = 4.*PI / TP_WVL !4pi - do II = G%isdB,G%iedB - do jj = G%jsd,G%jed + do jj = G%jsd,G%jed + do II = G%isdB,G%iedB IIm1 = max(1,II-1) Bottom = 0.0 MidPoint = 0.0 @@ -550,8 +550,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - do ii = G%isd,G%ied - do JJ = G%jsdB,G%jedB + do JJ = G%jsdB,G%jedB + do ii = G%isd,G%ied JJm1 = max(1,JJ-1) Bottom = 0.0 MidPoint = 0.0 @@ -572,8 +572,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) CS%Us0_x(:,:) = 0.0 CS%Us0_y(:,:) = 0.0 ! Computing X direction Stokes drift - do II = G%isdB,G%iedB - do jj = G%jsd,G%jed + do jj = G%jsd,G%jed + do II = G%isdB,G%iedB ! 1. First compute the surface Stokes drift ! by integrating over the partitionas. do b = 1,CS%NumBands @@ -630,8 +630,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo ! Computing Y direction Stokes drift - do ii = G%isd,G%ied - do JJ = G%jsdB,G%jedB + do JJ = G%jsdB,G%jedB + do ii = G%isd,G%ied ! Compute the surface values. do b = 1,CS%NumBands if (PartitionMode==0) then @@ -688,8 +688,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo elseif (WaveMethod==DHH85) then if (.not.(StaticWaves .and. DHH85_is_set)) then - do II = G%isdB,G%iedB - do jj = G%jsd,G%jed + do jj = G%jsd,G%jed + do II = G%isdB,G%iedB bottom = 0.0 do kk = 1,G%ke Top = Bottom @@ -706,8 +706,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - do ii = G%isd,G%ied - do JJ = G%jsdB,G%jedB + do JJ = G%jsdB,G%jedB + do ii = G%isd,G%ied Bottom = 0.0 do kk=1, G%ke Top = Bottom @@ -732,13 +732,13 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) endif else! Keep this else, fallback to 0 Stokes drift do kk= 1,G%ke - do II = G%isdB,G%iedB - do jj = G%jsd,G%jed + do jj = G%jsd,G%jed + do II = G%isdB,G%iedB CS%Us_x(II,jj,kk) = 0. enddo enddo - do ii = G%isd,G%ied - do JJ = G%jsdB,G%jedB + do JJ = G%jsdB,G%jedB + do ii = G%isd,G%ied CS%Us_y(ii,JJ,kk) = 0. enddo enddo @@ -748,8 +748,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! 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 ii = G%isc,G%iec - do jj = G%jsc, G%jec + 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,:),Override_MA=.false.,WAVES=CS) From 2fd4596c79b7574264bc3547ab9d4697d252d80a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Jan 2021 17:59:51 -0500 Subject: [PATCH 104/212] Corrected yet another OMP directive Added GV to the shared declaration in another openMP directive. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 6ebe162aab..0dfa29931d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1477,7 +1477,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then - !$OMP parallel do default(none) shared(G, dt, scalar, dtracer) + !$OMP parallel do default(none) shared(G, GV, dt, scalar, dtracer) do k = 1, GV%ke do j = G%jsc, G%jec do i = G%isc, G%iec From 633dc9241b698c3512a9c09eb58f3f12897ced8a Mon Sep 17 00:00:00 2001 From: jiandewang Date: Wed, 6 Jan 2021 14:06:04 -0500 Subject: [PATCH 105/212] add documentation for mom_cap_methods remove duplicated declearation of function chkerr, change case to match --- config_src/nuopc_driver/mom_cap.F90 | 13 +--- config_src/nuopc_driver/mom_cap_methods.F90 | 69 ++++++++++----------- config_src/nuopc_driver/mom_cap_time.F90 | 13 +--- config_src/nuopc_driver/time_utils.F90 | 13 +--- 4 files changed, 36 insertions(+), 72 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 4bfc9e1cb6..f0ce8720bb 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -36,6 +36,7 @@ module MOM_cap_mod use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh use MOM_cap_time, only: AlarmInit use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, state_diagnose +use MOM_cap_methods, only: ChkErr #ifdef CESMCOUPLED use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit #endif @@ -2049,18 +2050,6 @@ subroutine shr_file_getLogUnit(nunit) end subroutine shr_file_getLogUnit #endif -logical function chkerr(rc, line, file) - integer, intent(in) :: rc - integer, intent(in) :: line - character(len=*), intent(in) :: file - integer :: lrc - chkerr = .false. - lrc = rc - if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - chkerr = .true. - endif -end function chkerr - !> !! @page nuopc_cap NUOPC Cap !! @author Fei Liu (fei.liu@gmail.com) diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 1d51c1e6dd..39f450d453 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -30,6 +30,7 @@ module MOM_cap_methods public :: mom_import public :: mom_export public :: state_diagnose +public :: ChkErr private :: State_getImport private :: State_setExport @@ -251,9 +252,9 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- - ! Partitioned Stokes Drift Components + ! Partitioned Stokes Drift Components !---- - if ( associated(ice_ocean_boundary%ustkb) ) then + if ( associated(ice_ocean_boundary%ustkb) ) then allocate(stkx1(isc:iec,jsc:jec)) allocate(stky1(isc:iec,jsc:jec)) allocate(stkx2(isc:iec,jsc:jec)) @@ -765,15 +766,18 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid end subroutine State_SetExport +!> This subroutine writes the minimum, maximum and sum of each field +!! contained within an ESMF state. subroutine state_diagnose(State, string, rc) ! ---------------------------------------------- ! Diagnose status of State ! ---------------------------------------------- - type(ESMF_State), intent(in) :: state - character(len=*), intent(in) :: string - integer , intent(out) :: rc + type(ESMF_State), intent(in) :: state !< An ESMF State + character(len=*), intent(in) :: string !< A string indicating whether the State is an + !! import or export State + integer , intent(out) :: rc !< Return code ! local variables integer :: i,j,n @@ -787,19 +791,19 @@ subroutine state_diagnose(State, string, rc) ! ---------------------------------------------- call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(lfieldnamelist(fieldCount)) call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1, fieldCount call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then ! no local data @@ -829,23 +833,16 @@ subroutine state_diagnose(State, string, rc) end subroutine state_diagnose -!=============================================================================== - +!> Obtain a pointer to a rank 1 or rank 2 ESMF field subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) - ! ---------------------------------------------- - ! for a field, determine rank and return fldptr1 or fldptr2 - ! abort is true by default and will abort if fldptr is not yet allocated in field - ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false - ! ---------------------------------------------- - ! input/output variables - type(ESMF_Field) , intent(in) :: field - real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr1(:) - real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr2(:,:) - integer , intent(out) , optional :: rank - logical , intent(in) , optional :: abort - integer , intent(out) , optional :: rc + type(ESMF_Field) , intent(in) :: field !< An ESMF field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr1(:) !< A pointer to a rank 1 ESMF field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr2(:,:) !< A pointer to a rank 2 ESMF field + integer , intent(out) , optional :: rank !< Field rank + logical , intent(in) , optional :: abort !< Abort code + integer , intent(out) , optional :: rc !< Return code ! local variables type(ESMF_GeomType_Flag) :: geomtype @@ -872,7 +869,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) lrank = -99 call ESMF_FieldGet(field, status=status, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then lrank = 0 @@ -886,20 +883,20 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) else call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (geomtype == ESMF_GEOMTYPE_GRID) then call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return elseif (geomtype == ESMF_GEOMTYPE_MESH) then call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(field, mesh=lmesh, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (nnodes == 0 .and. nelements == 0) lrank = 0 - else + else call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & ESMF_LOGMSG_INFO) rc = ESMF_FAILURE @@ -917,7 +914,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) return endif call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return elseif (lrank == 2) then if (.not.present(fldptr2)) then call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & @@ -926,7 +923,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) return endif call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) @@ -942,16 +939,16 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) end subroutine field_getfldptr -logical function chkerr(rc, line, file) +logical function ChkErr(rc, line, file) integer, intent(in) :: rc integer, intent(in) :: line character(len=*), intent(in) :: file integer :: lrc - chkerr = .false. + ChkErr = .false. lrc = rc if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - chkerr = .true. + ChkErr = .true. endif -end function chkerr +end function ChkErr end module MOM_cap_methods diff --git a/config_src/nuopc_driver/mom_cap_time.F90 b/config_src/nuopc_driver/mom_cap_time.F90 index aa1a6c7072..7f210bda71 100644 --- a/config_src/nuopc_driver/mom_cap_time.F90 +++ b/config_src/nuopc_driver/mom_cap_time.F90 @@ -16,6 +16,7 @@ module MOM_cap_time use ESMF , only : ESMF_RC_ARG_BAD use ESMF , only : operator(<), operator(/=), operator(+), operator(-), operator(*) , operator(>=) use ESMF , only : operator(<=), operator(>), operator(==) +use MOM_cap_methods , only : ChkErr implicit none; private @@ -336,16 +337,4 @@ subroutine date2ymd (date, year, month, day) end subroutine date2ymd -logical function chkerr(rc, line, file) - integer, intent(in) :: rc - integer, intent(in) :: line - character(len=*), intent(in) :: file - integer :: lrc - chkerr = .false. - lrc = rc - if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - chkerr = .true. - endif -end function chkerr - end module MOM_cap_time diff --git a/config_src/nuopc_driver/time_utils.F90 b/config_src/nuopc_driver/time_utils.F90 index db056f4bf5..81efcd2765 100644 --- a/config_src/nuopc_driver/time_utils.F90 +++ b/config_src/nuopc_driver/time_utils.F90 @@ -14,6 +14,7 @@ module time_utils_mod use ESMF, only: ESMF_Time, ESMF_TimeGet, ESMF_LogFoundError use ESMF, only: ESMF_LOGERR_PASSTHRU,ESMF_TimeInterval use ESMF, only: ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_SUCCESS +use MOM_cap_methods, only: ChkErr implicit none; private @@ -160,16 +161,4 @@ function string_to_date(string, rc) end function string_to_date -logical function chkerr(rc, line, file) - integer, intent(in) :: rc - integer, intent(in) :: line - character(len=*), intent(in) :: file - integer :: lrc - chkerr = .false. - lrc = rc - if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - chkerr = .true. - endif -end function chkerr - end module time_utils_mod From 1480fbee4bca2b02c2bb1b26761923f47402e14e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 8 Jan 2021 03:28:32 -0500 Subject: [PATCH 106/212] Fix non-standard indentation Fixed non-standard 5- and 7-point initial indentation on scattered lines throughout the code in MOM6/src. All answers are bitwise identical, and there are only changes in white-space. --- src/ALE/coord_rho.F90 | 8 +- src/core/MOM.F90 | 12 +- src/core/MOM_dynamics_split_RK2.F90 | 2 +- src/core/MOM_open_boundary.F90 | 40 +++-- src/diagnostics/MOM_diagnostics.F90 | 8 +- src/diagnostics/MOM_sum_output.F90 | 4 +- src/framework/MOM_horizontal_regridding.F90 | 144 +++++++++--------- src/framework/MOM_io.F90 | 4 +- src/framework/MOM_restart.F90 | 18 +-- src/ice_shelf/MOM_ice_shelf.F90 | 26 ++-- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 4 +- .../vertical/MOM_opacity.F90 | 4 +- .../vertical/MOM_vert_friction.F90 | 2 +- src/tracer/MOM_tracer_advect.F90 | 10 +- src/tracer/MOM_tracer_diabatic.F90 | 6 +- src/user/DOME_initialization.F90 | 2 +- src/user/Idealized_Hurricane.F90 | 2 +- src/user/MOM_wave_interface.F90 | 62 ++++---- 18 files changed, 177 insertions(+), 181 deletions(-) diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index c1e35ac314..6c9934ce38 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -97,10 +97,10 @@ 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 [ppt] type(EOS_type), pointer :: eqn_of_state !< Equation of state structure 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 + 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] - 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) :: h_neglect !< A negligibly small width for the purpose !! of cell reconstructions [H ~> m or kg m-2] @@ -127,7 +127,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & z0_top = z_rigid_top eta=z0_top if (present(eta_orig)) then - eta=eta_orig + eta=eta_orig endif endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f11ce42407..49cfedc8b8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3280,13 +3280,13 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo do i=is,ie - ! set melt_potential to zero to avoid passing previous values - sfc_state%melt_potential(i,j) = 0.0 + ! set melt_potential to zero to avoid passing previous values + sfc_state%melt_potential(i,j) = 0.0 - 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) - endif + 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) + endif enddo enddo ! end of j loop endif ! melt_potential diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index e7c5a71930..2be0a978c1 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1265,7 +1265,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 ; 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) + CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then H_rescale = GV%m_to_H / GV%m_to_H_restart diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3fc0c9bcba..0673d7ca5b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4958,16 +4958,16 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart type(OBC_segment_type), pointer :: segment=>NULL() if (.not. associated(OBC)) & - call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& + call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& "uninitialized OBC control structure") if (associated(OBC%rx_normal) .or. associated(OBC%ry_normal) .or. & associated(OBC%rx_oblique) .or. associated(OBC%ry_oblique) .or. associated(OBC%cff_normal)) & - call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& + call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) & - call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& + call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") ! *** This is a temporary work around for restarts with OBC segments. @@ -5188,8 +5188,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! 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 - contractions = contractions + 1 + eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z + contractions = contractions + 1 endif enddo @@ -5197,27 +5197,27 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! Collapse layers to thinnest possible if the thickness less than ! the thinnest possible (or negative). 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 - segment%field(fld)%dz_src(i,j,k) = GV%Angstrom_Z + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + segment%field(fld)%dz_src(i,j,k) = GV%Angstrom_Z else - segment%field(fld)%dz_src(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) + segment%field(fld)%dz_src(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) endif enddo ! 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 - dilations = dilations + 1 - ! expand bottom-most cell only - eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) - 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 - ! dilate = (eta(i,j,1) + G%bathyT(i,j)) / (eta(i,j,1) - eta(i,j,nz+1)) - ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k) * dilate ; enddo - ! endif - !do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + segment%field(fld)%dz_src(i,j,k) ; enddo + dilations = dilations + 1 + ! expand bottom-most cell only + eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) + 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 + ! dilate = (eta(i,j,1) + G%bathyT(i,j)) / (eta(i,j,1) - eta(i,j,nz+1)) + ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k) * dilate ; enddo + ! 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 @@ -5241,8 +5241,6 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! endif deallocate(eta) - - end subroutine adjustSegmentEtaToFitBathymetry !> This is more of a rotate initialization than an actual rotate diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e0dc3c95d4..6a53ffb1fc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -501,7 +501,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! area mean SST if (CS%id_tosga > 0) then do j=js,je ; do i=is,ie - surface_field(i,j) = tv%T(i,j,1) + surface_field(i,j) = tv%T(i,j,1) enddo ; enddo tosga = global_area_mean(surface_field, G) call post_data(CS%id_tosga, tosga, CS%diag) @@ -1024,9 +1024,9 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (.not.G%symmetric) then if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_BT) .OR. & - associated(CS%KE_CorAdv) .OR. associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. & - associated(CS%KE_horvisc) .OR. associated(CS%KE_dia) ) then - call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + associated(CS%KE_CorAdv) .OR. associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. & + associated(CS%KE_horvisc) .OR. associated(CS%KE_dia) ) then + call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) endif endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 03204e4322..550f4d65e8 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1022,8 +1022,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & - fluxes%seaice_melt_heat(i,j) + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & + fluxes%seaice_melt_heat(i,j) enddo ; enddo ; endif ! smg: new code diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 4f98038f12..44df470928 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -475,66 +475,66 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, write(laynum,'(I8)') k ; laynum = adjustl(laynum) mask_in = 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 - rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) - - do j=js,je - do i=is,ie - if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion - else - tr_in(i,j) = missing_value - endif - enddo - enddo + 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 + rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + "error reading level "//trim(laynum)//" of variable "//& + trim(varnam)//" in file "// trim(filename)) + + do j=js,je + do i=is,ie + if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion + else + tr_in(i,j) = missing_value + endif + enddo + enddo else - if (is_root_pe()) then - start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd - rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) - - if (add_np) then - last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 - do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 - endif - enddo - if (npole > 0) then - pole=pole/npole - else - pole=missing_value - endif - tr_inp(:,1:jd) = tr_in(:,:) - tr_inp(:,jdp) = pole + if (is_root_pe()) then + start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd + rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + "error reading level "//trim(laynum)//" of variable "//& + trim(varnam)//" in file "// trim(filename)) + + if (add_np) then + last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 + do i=1,id + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + pole = pole+last_row(i) + npole = npole+1.0 + endif + enddo + if (npole > 0) then + pole=pole/npole else - tr_inp(:,:) = tr_in(:,:) + pole=missing_value endif - endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole + else + tr_inp(:,:) = tr_in(:,:) + endif + endif - call mpp_sync() - call mpp_broadcast(tr_inp, id*jdp, root_PE()) - call mpp_sync_self() + call mpp_sync() + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion - else - tr_inp(i,j) = missing_value - endif - enddo - enddo + do j=1,jdp + do i=1,id + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + else + tr_inp(i,j) = missing_value + endif + enddo + enddo endif @@ -542,21 +542,21 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (.not. is_ongrid) then - if (k == 1) then - call horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & - interp_method='bilinear',src_modulo=.true.) - endif - - if (debug) then - call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') - endif + if (k == 1) then + call horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & + interp_method='bilinear',src_modulo=.true.) + endif + + if (debug) then + call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') + endif endif tr_out(:,:) = 0.0 if (is_ongrid) then - tr_out(is:ie,js:je)=tr_in(is:ie,js:je) + tr_out(is:ie,js:je)=tr_in(is:ie,js:je) else - call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) endif mask_out=1.0 @@ -591,14 +591,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then - if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg - endif + if (homogenize) then + call sum_across_PEs(nPoints) + call sum_across_PEs(varAvg) + if (nPoints>0) then + varAvg = varAvg/real(nPoints) + endif + tr_out(:,:) = varAvg + endif endif ! tr_out contains input z-space data on the model grid with missing values diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 529c725274..f755b7f675 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -331,10 +331,10 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit pack = 1 if (present(checksums)) then - call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack, checksum=checksums(k,:)) else - call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack) endif enddo diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d9206f5bef..619aff6f18 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1419,15 +1419,15 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & do while (err == 0) restartname = trim(CS%restartfile) - !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 - 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 + ! 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 + 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 filepath = trim(directory) // trim(restartname) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5829e49ed3..f6c6768a85 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1510,12 +1510,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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));tmp2d(:,:)=0.0 - call MOM_read_data(TideAmp_file, 'tideamp', tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) - call rotate_array(tmp2d,CS%turns, CS%utide) - deallocate(tmp2d) + allocate(tmp2d(CS%Grid_in%isd:CS%Grid_in%ied,CS%Grid_in%jsd:CS%Grid_in%jed)) ; tmp2d(:,:)=0.0 + call MOM_read_data(TideAmp_file, 'tideamp', 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', CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) endif else call get_param(param_file, mdl, "UTIDE", utide, & @@ -1592,7 +1592,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file, & + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file, & CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness @@ -1703,11 +1703,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "ice sheet/shelf thickness", "m") if (PRESENT(sfc_state_in)) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & hor_grid='Cu',z_grid='1') - v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & hor_grid='Cv',z_grid='1') - call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc,v_desc, & + call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & .false., CS%restart_CSp) endif endif @@ -1868,11 +1868,11 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) 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.) if (CS%rotate_index) then - allocate(forces) - call allocate_mech_forcing(forces_in, CS%Grid, forces) - call rotate_mech_forcing(forces_in, CS%turns, forces) + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) else - forces=>forces_in + forces=>forces_in endif call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 547f9e6812..90ae47450d 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -483,9 +483,9 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & if (is_root_pe() .and. diag_CS%doc_unit > 0) then if (primary_id > 0) then - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' else - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' endif write(diag_CS%doc_unit, '(a)') trim(mesg) if (present(long_name)) call describe_option("long_name", long_name, diag_CS) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index c553c41fc6..83d70c7ae3 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -402,7 +402,7 @@ 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/) + 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. Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl @@ -423,7 +423,7 @@ function SW_pen_frac_morel(chl_data) ! three-dimensional chl-a values. real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2. 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/) 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 * & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 40f6ca8c6a..7e2c2c6926 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -969,7 +969,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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) endif - endif + endif endif ; enddo ; enddo ! i & k loops endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index f3e80c791e..a3c9965a11 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -727,7 +727,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real, dimension(SZI_(G),ntr,SZJ_(G)) :: & slope_y ! The concentration slope per grid point [conc]. real, dimension(SZI_(G),ntr,SZJB_(G)) :: & - flux_y ! The tracer flux across a boundary [H m2 conc ~> m3 conc or kg conc]. + flux_y ! The tracer flux across a boundary [H m2 conc ~> m3 conc or kg conc]. real, dimension(SZI_(G),ntr,SZJB_(G)) :: & T_tmp ! The copy of the tracer concentration at constant i,k [H m2 conc ~> m3 conc or kg conc]. real :: maxslope ! The maximum concentration slope per grid point @@ -796,10 +796,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !else ! slope_y(i,m,j) = G%mask2dCv(i,J) * G%mask2dCv(i,J-1) * 0.5*maxslope !endif - Tp = Tr(m)%t(i,j+1,k) ; Tc = Tr(m)%t(i,j,k) ; Tm = Tr(m)%t(i,j-1,k) - dMx = max( Tp, Tc, Tm ) - Tc - dMn= Tc - min( Tp, Tc, Tm ) - slope_y(i,m,j) = G%mask2dCv(i,J)*G%mask2dCv(i,J-1) * & + Tp = Tr(m)%t(i,j+1,k) ; Tc = Tr(m)%t(i,j,k) ; Tm = Tr(m)%t(i,j-1,k) + dMx = max( Tp, Tc, Tm ) - Tc + dMn = Tc - min( Tp, Tc, Tm ) + slope_y(i,m,j) = G%mask2dCv(i,J)*G%mask2dCv(i,J-1) * & sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) enddo ; enddo ; endif ; enddo ! End of i-, m-, & j- loops. endif ! usePLMslope diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 567fa2897e..9be4af08dc 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -191,8 +191,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + sfc_src(i,j) - endif - enddo + endif ; enddo do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > -0.5) then c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = h_old(i,j,k) + h_neglect @@ -391,8 +390,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + sfc_src(i,j) - endif - enddo + endif ; enddo do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > -0.5) then c1(i,k) = ent(i,j,K) * b1(i) h_tr = h_old(i,j,k) + h_neglect diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 9e749b8315..c56e2ab63f 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -193,7 +193,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) if (G%geoLonT(i,j) > 1400.0) then ; damp_new = 10.0 elseif (G%geoLonT(i,j) > 1300.0) then - damp_new = 10.0 * (G%geoLonT(i,j)-1300.0)/100.0 + damp_new = 10.0 * (G%geoLonT(i,j)-1300.0)/100.0 else ; damp_new = 0.0 endif diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index adaee16d4e..7182fc364a 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -520,7 +520,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = C**2 * 1.2 * exp(1.0) + B = C**2 * 1.2 * exp(1.0) endif elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 3e078b135b..33a255b687 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -69,42 +69,42 @@ module MOM_wave_interface ! Surface Wave Dependent 1d/2d/3d vars real, allocatable, dimension(:), public :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] + WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] real, allocatable, dimension(:), public :: & - Freq_Cen !< Frequency bands for read/coupled [s-1] + Freq_Cen !< Frequency bands for read/coupled [s-1] real, allocatable, dimension(:), public :: & - PrescribedSurfStkX !< Surface Stokes drift if prescribed [m s-1] + PrescribedSurfStkX !< Surface Stokes drift if prescribed [m s-1] real, allocatable, dimension(:), public :: & - PrescribedSurfStkY !< Surface Stokes drift if prescribed [m s-1] + PrescribedSurfStkY !< Surface Stokes drift if prescribed [m s-1] real, allocatable, dimension(:,:,:), public :: & - Us_x !< 3d zonal Stokes drift profile [m s-1] - !! Horizontal -> U points - !! Vertical -> Mid-points + Us_x !< 3d zonal Stokes drift profile [m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_y !< 3d meridional Stokes drift profile [m s-1] - !! Horizontal -> V points - !! Vertical -> Mid-points + Us_y !< 3d meridional Stokes drift profile [m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points real, allocatable, dimension(:,:), public :: & - La_SL,& !< SL Langmuir number (directionality factored later) - !! Horizontal -> H points - La_Turb !< Aligned Turbulent Langmuir number - !! Horizontal -> H points + La_SL,& !< SL Langmuir number (directionality factored later) + !! Horizontal -> H points + La_Turb !< Aligned Turbulent Langmuir number + !! Horizontal -> H points real, allocatable, dimension(:,:), public :: & - US0_x !< Surface Stokes Drift (zonal, m/s) - !! Horizontal -> U points + US0_x !< Surface Stokes Drift (zonal, m/s) + !! Horizontal -> U points real, allocatable, dimension(:,:), public :: & - US0_y !< Surface Stokes Drift (meridional, m/s) - !! Horizontal -> V points + US0_y !< Surface Stokes Drift (meridional, m/s) + !! Horizontal -> V points real, allocatable, dimension(:,:,:), public :: & - STKx0 !< Stokes Drift spectrum (zonal, m/s) - !! Horizontal -> U points - !! 3rd dimension -> Freq/Wavenumber + STKx0 !< Stokes Drift spectrum (zonal, m/s) + !! Horizontal -> U points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - STKy0 !< Stokes Drift spectrum (meridional, m/s) - !! Horizontal -> V points - !! 3rd dimension -> Freq/Wavenumber + STKy0 !< Stokes Drift spectrum (meridional, m/s) + !! Horizontal -> V points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] ! Pointers to auxiliary fields type(time_type), pointer, public :: Time !< A pointer to the ocean model's clock. @@ -475,14 +475,14 @@ 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) - 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 + 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) :: 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]. + intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. ! Local Variables real :: Top, MidPoint, Bottom, one_cm real :: DecayScale From ee7dd32c8534154f0cacb5e113873eb31613b363 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 8 Jan 2021 05:18:49 -0500 Subject: [PATCH 107/212] +Add create_MOM_domain and MOM_domain_init.F90 Added the new file MOM_domain_init.F90, with a copy of MOM_domains_init, to facilitate the separation of the framework code into FMS-specific and FMS-independent directories, and use this new module in MOM.F90 and MOM_ice_shelf.F90. There is also a copy of MOM_domains_init still in MOM_domains.F90, so other modules, like SIS2, will continue to work. Some of the previous contents of MOM_domains_init have been transferred into the new publicly visible routines create_MOM_domain, MOM_thread_affinity_set and set_MOM_thread_affinity. Also removed several module use statements for MOM_domains_init that are not needed. All answers and output files are bitwise identical, but there are new public interfaces. --- src/core/MOM.F90 | 4 +- src/core/MOM_dynamics_split_RK2.F90 | 1 - src/core/MOM_dynamics_unsplit.F90 | 5 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 5 +- src/framework/MOM_domains.F90 | 359 +++++++++++++++----------- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- 6 files changed, 223 insertions(+), 155 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f11ce42407..9ed4959abd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -23,8 +23,8 @@ module MOM use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage -use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : sum_across_PEs, pass_var, pass_vector +use MOM_domain_init, only : MOM_domains_init +use MOM_domains, only : sum_across_PEs, pass_var, pass_vector, clone_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index e7c5a71930..30bf23819a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -16,7 +16,6 @@ module MOM_dynamics_split_RK2 use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids -use MOM_domains, only : MOM_domains_init 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 diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a8de99df47..10b1f2e857 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -61,9 +61,8 @@ module MOM_dynamics_unsplit use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids -use MOM_domains, only : MOM_domains_init, pass_var, pass_vector -use MOM_domains, only : pass_var_start, pass_var_complete -use MOM_domains, only : pass_vector_start, pass_vector_complete +use MOM_domains, only : pass_var, pass_var_start, pass_var_complete +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 diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index c9da85fda9..8ca671d463 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -59,9 +59,8 @@ module MOM_dynamics_unsplit_RK2 use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl -use MOM_domains, only : MOM_domains_init, pass_var, pass_vector -use MOM_domains, only : pass_var_start, pass_var_complete -use MOM_domains, only : pass_vector_start, pass_vector_complete +use MOM_domains, only : pass_var, pass_var_start, pass_var_complete +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_error_handler, only : MOM_set_verbosity diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 46cc9c526a..c71ec6b848 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -12,7 +12,7 @@ module MOM_domains use MOM_file_parser, only : param_file_type use MOM_string_functions, only : slasher -use mpp_domains_mod, only : mpp_define_layout, mpp_get_boundary +use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain @@ -36,7 +36,8 @@ module MOM_domains implicit none ; private public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 -public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain +public :: create_MOM_domain, clone_MOM_domain +public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain public :: pass_var, pass_vector, PE_here, root_PE, num_PEs public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete @@ -47,6 +48,7 @@ module MOM_domains public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape +public :: MOM_thread_affinity_set, set_MOM_thread_affinity public :: get_simple_array_i_ind, get_simple_array_j_ind public :: domain2D @@ -1169,7 +1171,7 @@ subroutine complete_group_pass(group, MOM_dom, clock) end subroutine complete_group_pass -!> MOM_domains_init initalizes a MOM_domain_type variable, based on the information +!> 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, & @@ -1183,8 +1185,9 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !! whether this domain is symmetric, regardless of !! whether the macro SYMMETRIC_MEMORY_ is defined. logical, optional, intent(in) :: static_memory !< If present and true, this - !! domain type is set up for static memory and error checking of - !! various input values is performed against those in the input file. + !! domain type is set up for static memory and error + !! checking of various input values is performed against + !! those in the input file. integer, optional, intent(in) :: NIHALO !< Default halo sizes, required !! with static memory. integer, optional, intent(in) :: NJHALO !< Default halo sizes, required @@ -1198,8 +1201,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, optional, intent(in) :: NJPROC !< Processor counts, required with !! static memory. integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the i- and j- - !! directions, and returns the actual halo size used. + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" !! if missing. character(len=*), optional, intent(in) :: include_name !< A name for model's include file, @@ -1211,46 +1214,43 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, dimension(2) :: layout = (/ 1, 1 /) integer, dimension(2) :: io_layout = (/ 0, 0 /) integer, dimension(4) :: global_indices -!$ integer :: ocean_nthreads ! Number of Openmp threads -!$ integer :: get_cpu_affinity, omp_get_thread_num, omp_get_num_threads -!$ logical :: ocean_omp_hyper_thread + !$ integer :: ocean_nthreads ! Number of Openmp threads + !$ logical :: ocean_omp_hyper_thread + integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain. + integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos. integer :: nihalo_dflt, njhalo_dflt integer :: pe, proc_used - integer :: X_FLAGS, Y_FLAGS - logical :: reentrant_x, reentrant_y, tripolar_N, is_static + logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. + logical, dimension(2,2) :: tripolar ! A set of flag indicating whether there is tripolar + ! connectivity for any of the four logical edges of the grid. + ! Currently only tripolar_N is implemented. + logical :: is_static ! If true, static memory is being used for this domain. + logical :: is_symmetric ! True if the domainn being set up will use symmetric 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 :: mask_table_exists character(len=128) :: mask_table, inputdir - character(len=64) :: dom_name, inc_nm + character(len=64) :: inc_nm character(len=200) :: mesg - integer :: xsiz, ysiz, nip_parsed, njp_parsed - integer :: isc,iec,jsc,jec ! The bounding indices of the computational domain. + integer :: nip_parsed, njp_parsed 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 - integer :: xhalo_d2,yhalo_d2 -! 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 ! This module's name. - if (.not.associated(MOM_dom)) then - allocate(MOM_dom) - allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) - endif - pe = PE_here() proc_used = num_PEs() mdl = "MOM_domains" - MOM_dom%symmetric = .true. - if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + is_symmetric = .true. ; if (present(symmetric)) is_symmetric = symmetric if (present(min_halo)) mdl = trim(mdl)//" min_halo" - dom_name = "MOM" ; inc_nm = "MOM_memory.h" - if (present(domain_name)) dom_name = trim(domain_name) - if (present(include_name)) inc_nm = trim(include_name) + inc_nm = "MOM_memory.h" ; if (present(include_name)) inc_nm = trim(include_name) nihalo_nm = "NIHALO" ; njhalo_nm = "NJHALO" layout_nm = "LAYOUT" ; io_layout_nm = "IO_LAYOUT" ; masktable_nm = "MASKTABLE" @@ -1283,36 +1283,29 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) - call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, & + call get_param(param_file, mdl, "REENTRANT_X", reentrant(1), & "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + call get_param(param_file, mdl, "REENTRANT_Y", reentrant(2), & "If true, the domain is meridionally reentrant.", & default=.false.) - call get_param(param_file, mdl, "TRIPOLAR_N", tripolar_N, & + tripolar(1:2,1:2) = .false. + call get_param(param_file, mdl, "TRIPOLAR_N", tripolar(2,2), & "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call fms_affinity_init -!$OMP PARALLEL -!$OMP master -!$ ocean_nthreads = omp_get_num_threads() -!$OMP END MASTER -!$OMP END PARALLEL -!$ if(ocean_nthreads < 2 ) 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.) -!$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & -!$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ call fms_affinity_set('OCEAN', ocean_omp_hyper_thread, ocean_nthreads) -!$ call omp_set_num_threads(ocean_nthreads) -!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() -!$ flush(6) -!$ endif + !$ 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.) + !$ 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) + !$ endif #endif - call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & + + call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", is_symmetric, & "If defined, the velocity point data domain includes "//& "every face of the thickness points. In other words, "//& "some arrays are larger than others, depending on where "//& @@ -1320,10 +1313,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "index of the velocity-point arrays is usually 0, not 1. "//& "This can only be set at compile time.",& layoutParam=.true.) - call get_param(param_file, mdl, "NONBLOCKING_UPDATES", MOM_dom%nonblocking_updates, & + call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & "If true, non-blocking halo updates may be used.", & default=.false., layoutParam=.true.) - call get_param(param_file, mdl, "THIN_HALO_UPDATES", MOM_dom%thin_halo_updates, & + call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & "If true, optional arguments may be used to specify the "//& "the width of the halos that are updated with each call.", & default=.true., layoutParam=.true.) @@ -1342,60 +1335,72 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & layoutParam=.true.) if (is_static) then - call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & "The total number of thickness grid points in the "//& "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NIGLOBAL) - call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & "The total number of thickness grid points in the "//& "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NJGLOBAL) - if (MOM_dom%niglobal /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") - if (MOM_dom%njglobal /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") + ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. + if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then + write( char_xsiz, '(i4)' ) NIPROC + write( char_ysiz, '(i4)' ) NJPROC + write( char_niglobal, '(i4)' ) NIGLOBAL + write( char_njglobal, '(i4)' ) NJGLOBAL + call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = (' & + //trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& + 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') + call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in '//trim(inc_nm)//' to use '//& + 'dynamic allocation, or change processor decomposition to evenly divide the domain.') + endif else - call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & "The total number of thickness grid points in the "//& "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) - call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & "The total number of thickness grid points in the "//& "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) endif - call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & + call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & "The number of halo points on each side in the x-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & default=nihalo_dflt, static_value=nihalo_dflt) - call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & + call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & "The number of halo points on each side in the y-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & default=njhalo_dflt, static_value=njhalo_dflt) if (present(min_halo)) then - MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) - min_halo(1) = MOM_dom%nihalo - MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) - min_halo(2) = MOM_dom%njhalo + n_halo(1) = max(n_halo(1), min_halo(1)) + min_halo(1) = n_halo(1) + n_halo(2) = max(n_halo(2), min_halo(2)) + min_halo(2) = n_halo(2) ! These are generally used only with static memory, so they are considerd layout params. - call log_param(param_file, mdl, "!NIHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) - call log_param(param_file, mdl, "!NJHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) + call log_param(param_file, mdl, "!NIHALO min_halo", n_halo(1), layoutParam=.true.) + call log_param(param_file, mdl, "!NJHALO min_halo", n_halo(2), layoutParam=.true.) endif if (is_static .and. .not.present(min_halo)) then - if (MOM_dom%nihalo /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + if (n_halo(1) /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for "//trim(nihalo_nm)//" domain size") - if (MOM_dom%njhalo /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + if (n_halo(2) /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for "//trim(njhalo_nm)//" domain size") endif - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal + global_indices(1) = 1 ; global_indices(2) = n_global(1) + global_indices(3) = 1 ; global_indices(4) = n_global(2) call get_param(param_file, mdl, "INPUTDIR", inputdir, do_not_log=.true., default=".") inputdir = slasher(inputdir) @@ -1447,7 +1452,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif if ( layout(1)==0 .and. layout(2)==0 ) & - call mpp_define_layout(global_indices, proc_used, layout) + call MOM_define_layout(global_indices, proc_used, layout) if ( layout(1)/=0 .and. layout(2)==0 ) layout(2) = proc_used/layout(1) if ( layout(1)==0 .and. layout(2)/=0 ) layout(1) = proc_used/layout(2) @@ -1471,63 +1476,125 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & layoutParam=.true.) ! Idiot check that fewer PEs than columns have been requested - if (layout(1)*layout(2)>MOM_dom%niglobal*MOM_dom%njglobal) then + if (layout(1)*layout(2)>n_global(1)*n_global(2)) then write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & - 'PEs but there are only',MOM_dom%niglobal*MOM_dom%njglobal,'columns in the model' + 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' call MOM_error(FATAL, mesg) endif - if (mask_table_exists) then - call MOM_error(NOTE, 'MOM_domains_init: reading maskmap information from '//& - trim(mask_table)) - allocate(MOM_dom%maskmap(layout(1), layout(2))) - call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) - endif + if (mask_table_exists) & + call MOM_error(NOTE, 'MOM_domains_init: reading maskmap information from '//trim(mask_table)) - ! Set up the I/O layout, and check that it uses an even multiple of the - ! number of PEs in each direction. + ! 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.) - if (io_layout(1) < 0) then - write(mesg,'("MOM_domains_init: IO_LAYOUT(1) = ",i4,". Negative values "//& - &"are not allowed in ")') io_layout(1) - call MOM_error(FATAL, mesg//trim(IO_layout_nm)) - elseif (io_layout(1) > 0) then ; if (modulo(layout(1), io_layout(1)) /= 0) then - write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & - &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') & - io_layout(1),layout(1) - call MOM_error(FATAL, mesg) - endif ; endif + call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, io_layout=io_layout, & + domain_name=domain_name, mask_table=mask_table, symmetric=symmetric, & + thin_halos=thin_halos, nonblocking=nonblocking) - if (io_layout(2) < 0) then - write(mesg,'("MOM_domains_init: IO_LAYOUT(2) = ",i4,". Negative values "//& - &"are not allowed in ")') io_layout(2) - call MOM_error(FATAL, mesg//trim(IO_layout_nm)) - elseif (io_layout(2) /= 0) then ; if (modulo(layout(2), io_layout(2)) /= 0) then - write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & - &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') & - io_layout(2),layout(2) - call MOM_error(FATAL, mesg) - endif ; endif +end subroutine MOM_domains_init - if (io_layout(2) == 0) io_layout(2) = layout(2) - if (io_layout(1) == 0) io_layout(1) = layout(1) +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, dimension(2,2), intent(in) :: tripolar !< If true the grid uses tripolar connectivity on the two + !! ends (first index) of the i- and j-grids (second index) + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds + integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. + integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. + integer :: xhalo_d2, yhalo_d2 + character(len=200) :: mesg ! A string for use in error messages + character(len=64) :: dom_name ! The domain name + logical :: mask_table_exists ! Mask_table is present and the file it points to exists + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + + dom_name = "MOM" ; if (present(domain_name)) dom_name = trim(domain_name) X_FLAGS = 0 ; Y_FLAGS = 0 - if (reentrant_x) X_FLAGS = CYCLIC_GLOBAL_DOMAIN - if (reentrant_y) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN - if (tripolar_N) then + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar(2,2)) then Y_FLAGS = FOLD_NORTH_EDGE - if (reentrant_y) call MOM_error(FATAL,"MOM_domains: "// & - "TRIPOLAR_N and REENTRANT_Y may not be defined together.") + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") endif - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + global_indices(1:4) = (/ 1, MOM_dom%niglobal, 1, MOM_dom%njglobal /) + + if (present(mask_table)) then + mask_table_exists = file_exist(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) + endif + else + mask_table_exists = .false. + endif if (mask_table_exists) then call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & @@ -1542,44 +1609,16 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & symmetry = MOM_dom%symmetric, name=dom_name) endif - if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & - (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain, io_layout) - endif - -! Save the extra data for creating other domains of different resolution that overlay this domain - MOM_dom%X_FLAGS = X_FLAGS - MOM_dom%Y_FLAGS = Y_FLAGS - MOM_dom%layout = layout - MOM_dom%io_layout = io_layout - - if (is_static) then - ! A requirement of equal sized compute domains is necessary when STATIC_MEMORY_ - ! is used. - call mpp_get_compute_domain(MOM_dom%mpp_domain,isc,iec,jsc,jec) - xsiz = iec - isc + 1 - ysiz = jec - jsc + 1 - if (xsiz*NIPROC /= MOM_dom%niglobal .OR. ysiz*NJPROC /= MOM_dom%njglobal) then - write( char_xsiz,'(i4)' ) NIPROC - write( char_ysiz,'(i4)' ) NJPROC - write( char_niglobal,'(i4)' ) MOM_dom%niglobal - write( char_njglobal,'(i4)' ) MOM_dom%njglobal - call MOM_error(WARNING,'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = (' & - //trim(char_xsiz)//','//trim(char_ysiz)// & - ') does not evenly divide size set by preprocessor macro ('& - //trim(char_niglobal)//','//trim(char_njglobal)// '). ') - call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in "//trim(inc_nm)//" to use & - &dynamic allocation, or change processor decomposition to evenly divide the domain.') - endif + if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) endif - global_indices(1) = 1 ; global_indices(2) = int(MOM_dom%niglobal/2) - global_indices(3) = 1 ; global_indices(4) = int(MOM_dom%njglobal/2) !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 xhalo_d2 = int(MOM_dom%nihalo/2) yhalo_d2 = int(MOM_dom%njhalo/2) + global_indices(1:4) = (/ 1, int(MOM_dom%niglobal/2), 1, int(MOM_dom%njglobal/2) /) if (mask_table_exists) then call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & xflags=X_FLAGS, yflags=Y_FLAGS, & @@ -1593,12 +1632,44 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & symmetry = MOM_dom%symmetric, name=trim("MOMc")) endif - if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & + if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. & (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain_d2, io_layout) + call MOM_define_io_domain(MOM_dom%mpp_domain_d2, MOM_dom%io_layout) endif -end subroutine MOM_domains_init +end subroutine create_MOM_domain + + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sest the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) +end subroutine set_MOM_thread_affinity !> 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. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5829e49ed3..a5dd92b640 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -15,8 +15,8 @@ module MOM_ice_shelf use MOM_IS_diag_mediator, only : diag_mediator_init, diag_mediator_end, set_diag_mediator_grid use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_IS_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_close_registration -use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_domain_init, only : MOM_domains_init +use MOM_domains, only : clone_MOM_domain, pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_dyn_horgrid, only : rescale_dyn_horgrid_bathymetry use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe From 7091a09c1c0f77e86efdaf08b928d210400dc6dd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 8 Jan 2021 10:42:56 -0500 Subject: [PATCH 108/212] +Add MOM_write_field Moved rotated_write_field from MOM_transform_FMS.F90 to MOM_io.F90 and renamed it to MOM_write_field, with the mpp_domain argument replaced with a MOM_domain argument. Also changed the calls in save_restart to reflect these changes. All answers and output files are identical. --- src/framework/MOM_io.F90 | 144 ++++++++++++++++++++++++--- src/framework/MOM_restart.F90 | 45 +++++---- src/framework/MOM_transform_FMS.F90 | 148 +--------------------------- 3 files changed, 156 insertions(+), 181 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 529c725274..eda00bfda0 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -3,13 +3,13 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type @@ -41,7 +41,7 @@ module MOM_io public :: close_file, create_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields public :: get_file_times, open_file, read_axis_data, read_data, read_field_chksum -public :: num_timelevels, MOM_read_data, MOM_read_vector, ensembler +public :: num_timelevels, MOM_read_data, MOM_read_vector, MOM_write_field, ensembler public :: reopen_file, slasher, write_field, write_version_number, MOM_io_init public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE @@ -80,6 +80,15 @@ module MOM_io module procedure MOM_read_data_0d end interface +!> Write a registered field to an output file +interface MOM_write_field + module procedure MOM_write_field_4d + module procedure MOM_write_field_3d + module procedure MOM_write_field_2d + module procedure MOM_write_field_1d + module procedure MOM_write_field_0d +end interface MOM_write_field + !> Read a pair of data fields representing the two components of a vector from a file interface MOM_read_vector module procedure MOM_read_vector_3d @@ -621,7 +630,7 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), intent(in) :: name !< variable name character(len=*), optional, intent(in) :: units !< variable units character(len=*), optional, intent(in) :: longname !< variable long name - character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering + character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name @@ -662,7 +671,7 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable character(len=*), optional, intent(in) :: longname !< long name of variable - character(len=*), optional, intent(in) :: hor_grid !< horizonal staggering of variable + character(len=*), optional, intent(in) :: hor_grid !< horizontal staggering of variable character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name @@ -721,8 +730,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable character(len=*), optional, intent(out) :: longname !< long name of variable - character(len=*), optional, intent(out) :: hor_grid !< horiz staggering of variable - character(len=*), optional, intent(out) :: z_grid !< vert staggering of variable + character(len=*), optional, intent(out) :: hor_grid !< horizontal staggering of variable + character(len=*), optional, intent(out) :: z_grid !< verticle staggering of variable character(len=*), optional, intent(out) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(out) :: cmor_field_name !< CMOR name character(len=*), optional, intent(out) :: cmor_units !< CMOR physical dimensions of variable @@ -1002,7 +1011,7 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied !! by before they are returned. integer :: is, ie, js, je @@ -1078,13 +1087,126 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data end subroutine MOM_read_vector_3d +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_0d + + !> Initialize the MOM_io module subroutine MOM_io_init(param_file) type(param_file_type), intent(in) :: param_file !< structure indicating the open file to !! parse for model parameter values. -! 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_io" ! This module's name. call log_version(param_file, mdl, version) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d9206f5bef..73c5cc94e1 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -9,15 +9,14 @@ module MOM_restart use MOM_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : MOM_read_data, read_data, get_filename_appendix, read_field_chksum +use MOM_io, only : MOM_read_data, read_data, MOM_write_field, read_field_chksum use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times -use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc +use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE 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 use MOM_transform_FMS, only : chksum => rotated_mpp_chksum -use MOM_transform_FMS, only : write_field => rotated_write_field use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -370,7 +369,7 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + 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 @@ -397,7 +396,7 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + 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 @@ -424,7 +423,7 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + 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 @@ -452,7 +451,7 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, '1' if absent + 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 @@ -503,7 +502,7 @@ function query_initialized_name(name, CS) result(query_initialized) ! This subroutine returns .true. if the field referred to by name has ! initialized from a restart file, and .false. otherwise. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -537,7 +536,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -564,7 +563,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -592,7 +591,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -620,7 +619,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -648,7 +647,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -677,7 +676,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -713,7 +712,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -749,7 +748,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. - integer :: m,n + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -908,10 +907,10 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ restartname = trim(CS%restartfile) if (present(filename)) restartname = trim(filename) if (PRESENT(time_stamped)) then ; if (time_stamped) then - call get_date(time,year,month,days,hour,minute,seconds) + call get_date(time, year, month, days, hour, minute, seconds) ! Compute the year-day, because I don't like months. - RWH do m=1,month-1 - days = days + days_in_month(set_date(year,m,2,0,0,0)) + days = days + days_in_month(set_date(year, m, 2, 0, 0, 0)) enddo seconds = seconds + 60*minute + 3600*hour if (year <= 9999) then @@ -1030,19 +1029,19 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then - call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & + call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & CS%var_ptr3d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & + call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & CS%var_ptr2d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & + call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & CS%var_ptr4d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - call write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & + call MOM_write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & restart_time) elseif (associated(CS%var_ptr0d(m)%p)) then - call write_field(unit, fields(m-start_var+1), CS%var_ptr0d(m)%p, & + call MOM_write_field(unit, fields(m-start_var+1), CS%var_ptr0d(m)%p, & restart_time) endif enddo diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 index 572a9717dc..a6c28717b3 100644 --- a/src/framework/MOM_transform_FMS.F90 +++ b/src/framework/MOM_transform_FMS.F90 @@ -5,19 +5,15 @@ module MOM_transform_FMS use horiz_interp_mod, only : horiz_interp_type use MOM_error_handler, only : MOM_error, FATAL -use MOM_io, only : fieldtype, write_field -use mpp_domains_mod, only : domain2D use mpp_mod, only : mpp_chksum use time_manager_mod, only : time_type use time_interp_external_mod, only : time_interp_external use MOM_array_transform, only : allocate_rotated_array, rotate_array -implicit none +implicit none ; private -private public rotated_mpp_chksum -public rotated_write_field public rotated_time_interp_external !> Rotate and compute the FMS (mpp) checksum of a field @@ -29,15 +25,6 @@ module MOM_transform_FMS module procedure rotated_mpp_chksum_real_4d end interface rotated_mpp_chksum -!> Rotate and write a registered field to an FMS output file -interface rotated_write_field - module procedure rotated_write_field_real_0d - module procedure rotated_write_field_real_1d - module procedure rotated_write_field_real_2d - module procedure rotated_write_field_real_3d - module procedure rotated_write_field_real_4d -end interface rotated_write_field - !> Read a field based on model time, and rotate to the model domain interface rotated_time_interp_external module procedure rotated_time_interp_external_0d @@ -166,139 +153,6 @@ function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & end function rotated_mpp_chksum_real_4d -! NOTE: In MOM_io, write_field points to mpp_write, which supports a very broad -! range of interfaces. Here, we only support the much more narrow family of -! mpp_write_2ddecomp functions used to write tiled data. - - -!> Write the rotation of a 1d field to an FMS output file -!! This function is provided to support the full FMS write_field interface. -subroutine rotated_write_field_real_0d(io_unit, field_md, field, tstamp, turns) - integer, intent(in) :: io_unit !> File I/O unit handle - type(fieldtype), intent(in) :: field_md !> FMS field metadata - real, intent(inout) :: field !> Unrotated field array - real, optional, intent(in) :: tstamp !> Model timestamp - integer, optional, intent(in) :: turns !> Number of quarter-turns - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for 0d fields.") - - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine rotated_write_field_real_0d - - -!> Write the rotation of a 1d field to an FMS output file -!! This function is provided to support the full FMS write_field interface. -subroutine rotated_write_field_real_1d(io_unit, field_md, field, tstamp, turns) - integer, intent(in) :: io_unit !> File I/O unit handle - type(fieldtype), intent(in) :: field_md !> FMS field metadata - real, intent(inout) :: field(:) !> Unrotated field array - real, optional, intent(in) :: tstamp !> Model timestamp - integer, optional, intent(in) :: turns !> Number of quarter-turns - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for 0d fields.") - - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine rotated_write_field_real_1d - - -!> Write the rotation of a 2d field to an FMS output file -subroutine rotated_write_field_real_2d(io_unit, field_md, domain, field, & - tstamp, tile_count, default_data, turns) - integer, intent(in) :: io_unit !> File I/O unit handle - type(fieldtype), intent(in) :: field_md !> FMS field metadata - type(domain2D), intent(inout) :: domain !> FMS MPP domain - real, intent(inout) :: field(:,:) !> Unrotated field array - real, optional, intent(in) :: tstamp !> Model timestamp - integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) - real, optional, intent(in) :: default_data !> Default fill value - integer, optional, intent(in) :: turns !> Number of quarter-turns - - real, allocatable :: field_rot(:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - else - call allocate_rotated_array(field, [1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - deallocate(field_rot) - endif -end subroutine rotated_write_field_real_2d - - -!> Write the rotation of a 3d field to an FMS output file -subroutine rotated_write_field_real_3d(io_unit, field_md, domain, field, & - tstamp, tile_count, default_data, turns) - integer, intent(in) :: io_unit !> File I/O unit handle - type(fieldtype), intent(in) :: field_md !> FMS field metadata - type(domain2D), intent(inout) :: domain !> FMS MPP domain - real, intent(inout) :: field(:,:,:) !> Unrotated field array - real, optional, intent(in) :: tstamp !> Model timestamp - integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) - real, optional, intent(in) :: default_data !> Default fill value - integer, optional, intent(in) :: turns !> Number of quarter-turns - - real, allocatable :: field_rot(:,:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - else - call allocate_rotated_array(field, [1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - deallocate(field_rot) - endif -end subroutine rotated_write_field_real_3d - - -!> Write the rotation of a 4d field to an FMS output file -subroutine rotated_write_field_real_4d(io_unit, field_md, domain, field, & - tstamp, tile_count, default_data, turns) - integer, intent(in) :: io_unit !> File I/O unit handle - type(fieldtype), intent(in) :: field_md !> FMS field metadata - type(domain2D), intent(inout) :: domain !> FMS MPP domain - real, intent(inout) :: field(:,:,:,:) !> Unrotated field array - real, optional, intent(in) :: tstamp !> Model timestamp - integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) - real, optional, intent(in) :: default_data !> Default fill value - integer, optional, intent(in) :: turns !> Number of quarter-turns - - real, allocatable :: field_rot(:,:,:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - else - call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=default_data) - deallocate(field_rot) - endif -end subroutine rotated_write_field_real_4d - - !> Read a scalar field based on model time !! This function is provided to support the full FMS time_interp_external !! interface. From 502eb301ee8012796ff8f73b79e7d814f20441a9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Jan 2021 03:38:26 -0500 Subject: [PATCH 109/212] (*)Call MOM_write_field in write_ocean_geometry_file Use calls to MOM_write_field in write_ocean_geometry_file, instead of calls write_field. Also added missing dimensional rescaling factors to the two area fields Ah and Aq, which will cause the output fields in the ocean_geometry.nc files to change, but they are now invariant to the choice of dimensional rescaling, whereas previously they had not been. All answers and output are otherwise bitwise identical, and even ocean_geometry.nc is identical if L_RESCALE_POWER = 0. --- .../MOM_shared_initialization.F90 | 52 +++++++++---------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index ec51a045cf..24318954a1 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -13,7 +13,7 @@ module MOM_shared_initialization use MOM_file_parser, only : get_param, log_param, param_file_type, log_version use MOM_io, only : close_file, create_file, fieldtype, file_exists, stdout use MOM_io, only : MOM_read_data, MOM_read_vector, SINGLE_FILE, MULTIPLE -use MOM_io, only : slasher, vardesc, write_field, var_desc +use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -1312,60 +1312,60 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) file_threading, dG=G) do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLatBu(I,J) ; enddo ; enddo - call write_field(unit, fields(1), G%Domain%mpp_domain, out_q) + call MOM_write_field(unit, fields(1), G%Domain, out_q) do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLonBu(I,J) ; enddo ; enddo - call write_field(unit, fields(2), G%Domain%mpp_domain, out_q) - call write_field(unit, fields(3), G%Domain%mpp_domain, G%geoLatT) - call write_field(unit, fields(4), G%Domain%mpp_domain, G%geoLonT) + call MOM_write_field(unit, fields(2), G%Domain, out_q) + call MOM_write_field(unit, fields(3), G%Domain, G%geoLatT) + call MOM_write_field(unit, fields(4), G%Domain, G%geoLonT) do j=js,je ; do i=is,ie ; out_h(i,j) = Z_to_m_scale*G%bathyT(i,j) ; enddo ; enddo - call write_field(unit, fields(5), G%Domain%mpp_domain, out_h) + call MOM_write_field(unit, fields(5), G%Domain, out_h) do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(i,J) = s_to_T_scale*G%CoriolisBu(I,J) ; enddo ; enddo - call write_field(unit, fields(6), G%Domain%mpp_domain, out_q) + call MOM_write_field(unit, fields(6), G%Domain, out_q) ! I think that all of these copies are holdovers from a much earlier ! ancestor code in which many of the metrics were macros that could have ! had reduced dimensions, and that they are no longer needed in MOM6. -RWH do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dxCv(i,J) ; enddo ; enddo - call write_field(unit, fields(7), G%Domain%mpp_domain, out_v) + call MOM_write_field(unit, fields(7), G%Domain, out_v) do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dyCu(I,j) ; enddo ; enddo - call write_field(unit, fields(8), G%Domain%mpp_domain, out_u) + call MOM_write_field(unit, fields(8), G%Domain, out_u) do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dxCu(I,j) ; enddo ; enddo - call write_field(unit, fields(9), G%Domain%mpp_domain, out_u) + call MOM_write_field(unit, fields(9), G%Domain, out_u) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dyCv(i,J) ; enddo ; enddo - call write_field(unit, fields(10), G%Domain%mpp_domain, out_v) + call MOM_write_field(unit, fields(10), G%Domain, out_v) do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale*G%dxT(i,j); enddo ; enddo - call write_field(unit, fields(11), G%Domain%mpp_domain, out_h) + call MOM_write_field(unit, fields(11), G%Domain, out_h) do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale*G%dyT(i,j) ; enddo ; enddo - call write_field(unit, fields(12), G%Domain%mpp_domain, out_h) + call MOM_write_field(unit, fields(12), G%Domain, out_h) do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(i,J) = L_to_m_scale*G%dxBu(I,J) ; enddo ; enddo - call write_field(unit, fields(13), G%Domain%mpp_domain, out_q) + call MOM_write_field(unit, fields(13), G%Domain, out_q) do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = L_to_m_scale*G%dyBu(I,J) ; enddo ; enddo - call write_field(unit, fields(14), G%Domain%mpp_domain, out_q) + call MOM_write_field(unit, fields(14), G%Domain, out_q) - do j=js,je ; do i=is,ie ; out_h(i,j) = G%areaT(i,j) ; enddo ; enddo - call write_field(unit, fields(15), G%Domain%mpp_domain, out_h) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%areaBu(I,J) ; enddo ; enddo - call write_field(unit, fields(16), G%Domain%mpp_domain, out_q) + do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale**2*G%areaT(i,j) ; enddo ; enddo + call MOM_write_field(unit, fields(15), G%Domain, out_h) + do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = L_to_m_scale**2*G%areaBu(I,J) ; enddo ; enddo + call MOM_write_field(unit, fields(16), G%Domain, out_q) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dx_Cv(i,J) ; enddo ; enddo - call write_field(unit, fields(17), G%Domain%mpp_domain, out_v) + call MOM_write_field(unit, fields(17), G%Domain, out_v) do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dy_Cu(I,j) ; enddo ; enddo - call write_field(unit, fields(18), G%Domain%mpp_domain, out_u) - call write_field(unit, fields(19), G%Domain%mpp_domain, G%mask2dT) + call MOM_write_field(unit, fields(18), G%Domain, out_u) + call MOM_write_field(unit, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dblock_u(I,j) ; enddo ; enddo - call write_field(unit, fields(20), G%Domain%mpp_domain, out_u) + call MOM_write_field(unit, fields(20), G%Domain, out_u) do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dopen_u(I,j) ; enddo ; enddo - call write_field(unit, fields(21), G%Domain%mpp_domain, out_u) + call MOM_write_field(unit, fields(21), G%Domain, out_u) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dblock_v(i,J) ; enddo ; enddo - call write_field(unit, fields(22), G%Domain%mpp_domain, out_v) + call MOM_write_field(unit, fields(22), G%Domain, out_v) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dopen_v(i,J) ; enddo ; enddo - call write_field(unit, fields(23), G%Domain%mpp_domain, out_v) + call MOM_write_field(unit, fields(23), G%Domain, out_v) endif call close_file(unit) From adb8ec46bebdfb8d43cddb186520d28c6fe17313 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Jan 2021 05:23:51 -0500 Subject: [PATCH 110/212] +Add deallocate_MOM_domain and get_layout_extents Added the new routines deallocate_MOM_domain, deallocate_domain_contents and get_layout_extents to standardize the clean-up of memory associated with MOM_domains, provide an interface for obtaining information about the global grid decomposition and limit the dependencies on mpp functions to calls that go through the MOM framework directory. All answers are bitwise identical, although there are new public interfaces. --- src/core/MOM_grid.F90 | 7 +-- src/framework/MOM_domains.F90 | 58 ++++++++++++++++++++-- src/initialization/MOM_grid_initialize.F90 | 43 +++++++--------- 3 files changed, 77 insertions(+), 31 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 8844c65f40..9ca98adf71 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2 +use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2, deallocate_MOM_domain use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_unit_scaling, only : unit_scale_type @@ -630,8 +630,9 @@ subroutine MOM_grid_end(G) deallocate(G%gridLonT) ; deallocate(G%gridLatT) deallocate(G%gridLonB) ; deallocate(G%gridLatB) - deallocate(G%Domain%mpp_domain) - deallocate(G%Domain) + ! The cursory flag avoids doing any deallocation of memory in the underlying + ! infrastructure to avoid problems due to shared pointers. + call deallocate_MOM_domain(G%Domain, cursory=.true.) end subroutine MOM_grid_end diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index c71ec6b848..dc1f8ff867 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -17,6 +17,7 @@ module MOM_domains use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain use mpp_domains_mod, only : global_field_sum => mpp_global_sum use mpp_domains_mod, only : mpp_update_domains, CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains @@ -37,6 +38,7 @@ module MOM_domains public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 public :: create_MOM_domain, clone_MOM_domain +public :: deallocate_MOM_domain, deallocate_domain_contents public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain public :: pass_var, pass_vector, PE_here, root_PE, num_PEs public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast @@ -47,7 +49,7 @@ module MOM_domains public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass -public :: compute_block_extent, get_global_shape +public :: compute_block_extent, get_global_shape, get_layout_extents public :: MOM_thread_affinity_set, set_MOM_thread_affinity public :: get_simple_array_i_ind, get_simple_array_j_ind public :: domain2D @@ -1639,6 +1641,42 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, lay end subroutine create_MOM_domain +!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type +!! and all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + + if (associated(MOM_domain)) then + call deallocate_domain_contents(MOM_domain, cursory) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> deallocate_domain_contents deallocates memory associated with pointers +!! inside of a MOM_domain_type. +subroutine deallocate_domain_contents(MOM_domain, cursory) + type(MOM_domain_type), intent(inout) :: MOM_domain !< A MOM_domain_type whose contents will be deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + + logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain%mpp_domain)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) + deallocate(MOM_domain%mpp_domain) + endif + if (associated(MOM_domain%mpp_domain_d2)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) + deallocate(MOM_domain%mpp_domain_d2) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + +end subroutine deallocate_domain_contents !> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. function MOM_thread_affinity_set() @@ -2041,13 +2079,27 @@ end subroutine get_simple_array_j_ind !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) - type(MOM_domain_type), intent(in) :: domain !< MOM domain + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information integer, intent(out) :: niglobal !< i-index global size of h-point arrays integer, intent(out) :: njglobal !< j-index global size of h-point arrays niglobal = domain%niglobal njglobal = domain%njglobal - end subroutine get_global_shape +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i + integer, dimension(:), allocatable, intent(inout) :: extent_j + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + end module MOM_domains diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 4526d9e9c7..eee168eefb 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -3,22 +3,19 @@ module MOM_grid_initialize ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : hchksum, Bchksum -use MOM_checksums, only : uvchksum, hchksum_pair, Bchksum_pair -use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast -use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair -use MOM_domains, only : To_North, To_South, To_East, To_West -use MOM_domains, only : MOM_define_domain, MOM_define_IO_domain -use MOM_domains, only : MOM_domain_type -use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid +use MOM_checksums, only : hchksum, Bchksum, uvchksum, hchksum_pair, Bchksum_pair +use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast +use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair +use MOM_domains, only : To_North, To_South, To_East, To_West +use MOM_domains, only : MOM_define_domain, MOM_define_IO_domain, get_layout_extents +use MOM_domains, only : MOM_domain_type, deallocate_domain_contents +use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io, only : MOM_read_data, read_data, slasher, file_exists, stdout -use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE -use MOM_unit_scaling, only : unit_scale_type - -use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io, only : MOM_read_data, read_data, slasher, file_exists, stdout +use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE +use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -192,8 +189,8 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) type(MOM_domain_type) :: SGdom ! Supergrid domain logical :: lon_bug ! If true use an older buggy answer in the tripolar longitude. integer :: i, j, i2, j2 - integer :: npei,npej - integer, dimension(:), allocatable :: exni,exnj + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout integer :: start(4), nread(4) call callTree_enter("set_grid_metrics_from_mosaic(), MOM_grid_initialize.F90") @@ -224,9 +221,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) nj = 2*(G%jec-G%jsc+1) ! j size of supergrid ! Define a domain for the supergrid (SGdom) - npei = G%domain%layout(1) ; npej = G%domain%layout(2) - allocate(exni(npei)) ; allocate(exnj(npej)) - call mpp_get_domain_extents(G%domain%mpp_domain, exni, exnj) + call get_layout_extents(G%domain, exni, exnj) allocate(SGdom%mpp_domain) SGdom%nihalo = 2*G%domain%nihalo+1 SGdom%njhalo = 2*G%domain%njhalo+1 @@ -243,19 +238,18 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & - xextent=exni,yextent=exnj, & + xextent=exni, yextent=exnj, & symmetry=.true., name="MOM_MOSAIC", maskmap=G%domain%maskmap) else call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & - xextent=exni,yextent=exnj, & + xextent=exni, yextent=exnj, & symmetry=.true., name="MOM_MOSAIC") endif call MOM_define_IO_domain(SGdom%mpp_domain, SGdom%io_layout) - deallocate(exni) - deallocate(exnj) + deallocate(exni, exnj) ! Read X from the supergrid tmpZ(:,:) = 999. @@ -346,8 +340,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) ni=SGdom%niglobal nj=SGdom%njglobal - call mpp_deallocate_domain(SGdom%mpp_domain) - deallocate(SGdom%mpp_domain) + call deallocate_domain_contents(SGdom) call pass_vector(dyCu, dxCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dxCu, dyCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) From d8806f48e4e81402c524d6cc47838f9ba9181c44 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 06:07:20 -0500 Subject: [PATCH 111/212] +Rename rotated_mpp_chksum to rotated_field_chksum Renamed rotated_mpp_chksum to rotated_field_chksum and moved the routines wrapped by this overloaded interface from MOM_transform_FMS.F90 to MOM_checksums.F90. Also provided access to mpp_chksum as field_chksum via MOM_coms.F90. Both of these are steps to clean up the MOM6 framework code and reduce the direct use of mpp routines in the rest of the MOM6 code. All answers are bitwise identical, but there are effectively new interfaces, and one existing interface was renamed. --- src/diagnostics/MOM_sum_output.F90 | 7 +- src/framework/MOM_checksums.F90 | 139 +++++++++++- src/framework/MOM_coms.F90 | 4 +- src/framework/MOM_domain_init.F90 | 330 ++++++++++++++++++++++++++++ src/framework/MOM_restart.F90 | 10 +- src/framework/MOM_transform_FMS.F90 | 132 +---------- 6 files changed, 474 insertions(+), 148 deletions(-) create mode 100644 src/framework/MOM_domain_init.F90 diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 03204e4322..8b24463af9 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -4,7 +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_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs +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 @@ -25,7 +25,6 @@ module MOM_sum_output use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use mpp_mod, only : mpp_chksum use netcdf @@ -1511,13 +1510,13 @@ subroutine get_depth_list_checksums(G, depth_chksum, area_chksum) do j=G%jsc,G%jec ; do i=G%isc,G%iec field(i,j) = G%bathyT(i,j) enddo ; enddo - write(depth_chksum, '(Z16)') mpp_chksum(field(:,:)) + write(depth_chksum, '(Z16)') field_chksum(field(:,:)) ! Area checksum do j=G%jsc,G%jec ; do i=G%isc,G%iec field(i,j) = G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) enddo ; enddo - write(area_chksum, '(Z16)') mpp_chksum(field(:,:)) + write(area_chksum, '(Z16)') field_chksum(field(:,:)) deallocate(field) end subroutine get_depth_list_checksums diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index c3174dbe7b..5c503836f0 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -3,10 +3,11 @@ module MOM_checksums ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_array_transform, only: rotate_array, rotate_array_pair, rotate_vector +use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector +use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs use MOM_coms, only : min_across_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_error_handler, only : MOM_error, FATAL, is_root_pe use MOM_file_parser, only : log_version, param_file_type use MOM_hor_index, only : hor_index_type, rotate_hor_index @@ -15,7 +16,7 @@ module MOM_checksums implicit none ; private -public :: chksum0, zchksum +public :: chksum0, zchksum, rotated_field_chksum public :: hchksum, Bchksum, uchksum, vchksum, qchksum, is_NaN, chksum public :: hchksum_pair, uvchksum, Bchksum_pair public :: MOM_checksums_init @@ -75,6 +76,15 @@ module MOM_checksums module procedure is_NaN_0d, is_NaN_1d, is_NaN_2d, is_NaN_3d end interface +!> Rotate and compute the checksum of a field +interface rotated_field_chksum + module procedure rotated_field_chksum_real_0d + module procedure rotated_field_chksum_real_1d + module procedure rotated_field_chksum_real_2d + module procedure rotated_field_chksum_real_3d + module procedure rotated_field_chksum_real_4d +end interface rotated_field_chksum + integer, parameter :: bc_modulus = 1000000000 !< Modulus of checksum bitcount integer, parameter :: default_shift=0 !< The default array shift logical :: calculateStatistics=.true. !< If true, report min, max and mean. @@ -2021,16 +2031,16 @@ function is_NaN_1d(x, skip_mpp) logical :: is_NaN_1d integer :: i, n - logical :: call_mpp + logical :: global_check n = 0 do i = LBOUND(x,1), UBOUND(x,1) if (is_NaN_0d(x(i))) n = n + 1 enddo - call_mpp = .true. - if (present(skip_mpp)) call_mpp = .not.skip_mpp + global_check = .true. + if (present(skip_mpp)) global_check = .not.skip_mpp - if (call_mpp) call sum_across_PEs(n) + if (global_check) call sum_across_PEs(n) is_NaN_1d = .false. if (n>0) is_NaN_1d = .true. @@ -2072,6 +2082,121 @@ function is_NaN_3d(x) end function is_NaN_3d +! The following set of routines do a checksum across the computational domain of +! a field, with the potential for rotation of this field and masking. + +!> 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 + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer, optional, intent(in) :: turns !< Number of quarter turns + integer :: chksum !< checksum of scalar + + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) +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 + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer, optional, intent(in) :: turns !< Number of quarter turns + integer :: chksum !< checksum of array + + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 1d fields.") + + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) +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 + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer, optional, intent(in) :: turns !< Number of quarter turns + integer :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +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 + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer, optional, intent(in) :: turns !< Number of quarter turns + integer :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +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 + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer, optional, intent(in) :: turns !< Number of quarter turns + integer :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_field_chksum_real_4d + + !> Write a message including the checksum of the non-shifted array subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 0c6b948980..04ed46ad22 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -9,13 +9,13 @@ module MOM_coms use memutils_mod, only : print_memuse_stats use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist -use mpp_mod, only : broadcast => mpp_broadcast +use mpp_mod, only : broadcast => mpp_broadcast, field_chksum => mpp_chksum use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end -public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) diff --git a/src/framework/MOM_domain_init.F90 b/src/framework/MOM_domain_init.F90 new file mode 100644 index 0000000000..25064cf24e --- /dev/null +++ b/src/framework/MOM_domain_init.F90 @@ -0,0 +1,330 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_init + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : num_PEs +use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_define_layout +use MOM_domains, only : MOM_thread_affinity_set, set_MOM_thread_affinity +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io, only : file_exists +use MOM_string_functions, only : slasher + +implicit none ; private + +public :: MOM_domains_init, MOM_domain_type + +contains + +!> 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, & + 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(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether this domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + logical, optional, intent(in) :: static_memory !< If present and true, this + !! domain type is set up for static memory and + !! error checking of various input values is + !! performed against those in the input file. + integer, optional, intent(in) :: NIHALO !< Default halo sizes, required + !! with static memory. + integer, optional, intent(in) :: NJHALO !< Default halo sizes, required + !! with static memory. + integer, optional, intent(in) :: NIGLOBAL !< Total domain sizes, required + !! with static memory. + integer, optional, intent(in) :: NJGLOBAL !< Total domain sizes, required + !! with static memory. + integer, optional, intent(in) :: NIPROC !< Processor counts, required with + !! static memory. + integer, optional, intent(in) :: NJPROC !< Processor counts, required with + !! static memory. + integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" + !! if missing. + character(len=*), optional, intent(in) :: include_name !< A name for model's include file, + !! "MOM_memory.h" if missing. + character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to + !! layout-specific parameters. + + ! Local variables + integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions + 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 + integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain + integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos + integer :: nihalo_dflt, njhalo_dflt ! The default halo sizes + integer :: PEs_used ! The number of processors used + logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. + logical, dimension(2,2) :: tripolar ! A set of flag indicating whether there is tripolar + ! connectivity for any of the four logical edges of the grid. + ! Currently only tripolar_N is implemented. + logical :: is_static ! If true, static memory is being used for this domain. + logical :: is_symmetric ! True if the domain being set up will use symmetric 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 :: 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 + character(len=64) :: inc_nm ! The name of the memory include file + character(len=200) :: mesg ! A string to use for error messages + + integer :: nip_parsed, njp_parsed + 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 + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl ! This module's name. + + PEs_used = num_PEs() + + mdl = "MOM_domains" !### Change this to "MOM_domain_init" + + is_symmetric = .true. ; if (present(symmetric)) is_symmetric = symmetric + if (present(min_halo)) mdl = trim(mdl)//" min_halo" + + inc_nm = "MOM_memory.h" ; if (present(include_name)) inc_nm = trim(include_name) + + nihalo_nm = "NIHALO" ; njhalo_nm = "NJHALO" + layout_nm = "LAYOUT" ; io_layout_nm = "IO_LAYOUT" ; masktable_nm = "MASKTABLE" + niproc_nm = "NIPROC" ; njproc_nm = "NJPROC" + if (present(param_suffix)) then ; if (len(trim(adjustl(param_suffix))) > 0) then + nihalo_nm = "NIHALO"//(trim(adjustl(param_suffix))) + njhalo_nm = "NJHALO"//(trim(adjustl(param_suffix))) + layout_nm = "LAYOUT"//(trim(adjustl(param_suffix))) + io_layout_nm = "IO_LAYOUT"//(trim(adjustl(param_suffix))) + masktable_nm = "MASKTABLE"//(trim(adjustl(param_suffix))) + niproc_nm = "NIPROC"//(trim(adjustl(param_suffix))) + njproc_nm = "NJPROC"//(trim(adjustl(param_suffix))) + endif ; endif + + is_static = .false. ; if (present(static_memory)) is_static = static_memory + if (is_static) then + if (.not.present(NIHALO)) call MOM_error(FATAL, "NIHALO must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJHALO)) call MOM_error(FATAL, "NJHALO must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NIGLOBAL)) call MOM_error(FATAL, "NIGLOBAL must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJGLOBAL)) call MOM_error(FATAL, "NJGLOBAL must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NIPROC)) call MOM_error(FATAL, "NIPROC must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJPROC)) call MOM_error(FATAL, "NJPROC must be "// & + "present in the call to MOM_domains_init with static memory.") + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) + call get_param(param_file, mdl, "REENTRANT_X", reentrant(1), & + "If true, the domain is zonally reentrant.", default=.true.) + call get_param(param_file, mdl, "REENTRANT_Y", reentrant(2), & + "If true, the domain is meridionally reentrant.", & + default=.false.) + tripolar(1:2,1:2) = .false. + call get_param(param_file, mdl, "TRIPOLAR_N", tripolar(2,2), & + "Use tripolar connectivity at the northern edge of the "//& + "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & + default=.false.) + +# ifndef NOT_SET_AFFINITY + !$ 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.) + !$ 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) + !$ endif +# endif + + call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", is_symmetric, & + "If defined, the velocity point data domain includes every face of the "//& + "thickness points. In other words, some arrays are larger than others, "//& + "depending on where they are on the staggered grid. Also, the starting "//& + "index of the velocity-point arrays is usually 0, not 1. "//& + "This can only be set at compile time.",& + layoutParam=.true.) + call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & + "If true, non-blocking halo updates may be used.", & + default=.false., layoutParam=.true.) + !### Note the duplicated "the the" in the following description, which should be fixed as a part + ! of a larger commit that also changes other MOM_parameter_doc file messages, but for now + ! reproduces the existing output files. + call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & + "If true, optional arguments may be used to specify the the width of the "//& + "halos that are updated with each call.", & + default=.true., layoutParam=.true.) + + nihalo_dflt = 4 ; njhalo_dflt = 4 + if (present(NIHALO)) nihalo_dflt = NIHALO + if (present(NJHALO)) njhalo_dflt = NJHALO + + call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & + "If STATIC_MEMORY_ is defined, the principle variables will have sizes that "//& + "are statically determined at compile time. Otherwise the sizes are not "//& + "determined until run time. The STATIC option is substantially faster, but "//& + "does not allow the PE count to be changed at run time. This can only be "//& + "set at compile time.", layoutParam=.true.) + + if (is_static) then + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + static_value=NIGLOBAL) + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + static_value=NJGLOBAL) + if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") + if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") + + ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. + if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then + write( char_xsiz, '(i4)' ) NIPROC + write( char_ysiz, '(i4)' ) NJPROC + write( char_niglobal, '(i4)' ) NIGLOBAL + write( char_njglobal, '(i4)' ) NJGLOBAL + call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& + trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& + 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') + call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in '//trim(inc_nm)//' to use '//& + 'dynamic allocation, or change processor decomposition to evenly divide the domain.') + endif + else + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + fail_if_missing=.true.) + endif + + call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & + "The number of halo points on each side in the x-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=nihalo_dflt, static_value=nihalo_dflt) + call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & + "The number of halo points on each side in the y-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=njhalo_dflt, static_value=njhalo_dflt) + if (present(min_halo)) then + n_halo(1) = max(n_halo(1), min_halo(1)) + min_halo(1) = n_halo(1) + n_halo(2) = max(n_halo(2), min_halo(2)) + min_halo(2) = n_halo(2) + ! These are generally used only with static memory, so they are considerd layout params. + call log_param(param_file, mdl, "!NIHALO min_halo", n_halo(1), layoutParam=.true.) + call log_param(param_file, mdl, "!NJHALO min_halo", n_halo(2), layoutParam=.true.) + endif + if (is_static .and. .not.present(min_halo)) then + if (n_halo(1) /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(nihalo_nm)//" domain size") + if (n_halo(2) /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(njhalo_nm)//" domain size") + endif + + 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) + + if (is_static) then + layout(1) = NIPROC ; layout(2) = NJPROC + else + call get_param(param_file, mdl, trim(layout_nm), layout, & + "The processor layout to be used, or 0, 0 to automatically set the layout "//& + "based on the number of processors.", default=0, do_not_log=.true.) + call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & + "The number of processors in the x-direction.", default=-1, do_not_log=.true.) + call get_param(param_file, mdl, trim(njproc_nm), njp_parsed, & + "The number of processors in the y-direction.", default=-1, do_not_log=.true.) + if (nip_parsed > -1) then + if ((layout(1) > 0) .and. (layout(1) /= nip_parsed)) & + call MOM_error(FATAL, trim(layout_nm)//" and "//trim(niproc_nm)//" set inconsistently. "//& + "Only LAYOUT should be used.") + layout(1) = nip_parsed + call MOM_mesg(trim(niproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& + "Shift to using "//trim(layout_nm)//" instead.") + endif + if (njp_parsed > -1) then + if ((layout(2) > 0) .and. (layout(2) /= njp_parsed)) & + call MOM_error(FATAL, trim(layout_nm)//" and "//trim(njproc_nm)//" set inconsistently. "//& + "Only "//trim(layout_nm)//" should be used.") + layout(2) = njp_parsed + call MOM_mesg(trim(njproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& + "Shift to using "//trim(layout_nm)//" instead.") + endif + + if ( (layout(1) == 0) .and. (layout(2) == 0) ) & + call MOM_define_layout( (/ 1, n_global(1), 1, n_global(2) /), PEs_used, layout) + if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) + if ( (layout(1) == 0) .and. (layout(2) /= 0) ) layout(1) = PEs_used / layout(2) + + if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then + write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & + & 2i4,", is not the number of PEs used, ",i5,".")') & + layout(1), layout(2), PEs_used + call MOM_error(FATAL, mesg) + endif + endif + call log_param(param_file, mdl, trim(niproc_nm), layout(1), & + "The number of processors in the x-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) + call log_param(param_file, mdl, trim(njproc_nm), layout(2), & + "The number of processors in the y-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) + call log_param(param_file, mdl, trim(layout_nm), layout, & + "The processor layout that was actually used.", layoutParam=.true.) + + ! Idiot check that fewer PEs than columns have been requested + if (layout(1)*layout(2) > n_global(1)*n_global(2)) then + write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & + 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' + call MOM_error(FATAL, mesg) + endif + + if (mask_table_exists) & + call MOM_error(NOTE, 'MOM_domains_init: reading maskmap information from '//trim(mask_table)) + + ! 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.) + + call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, & + io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & + symmetric=symmetric, thin_halos=thin_halos, nonblocking=nonblocking) + +end subroutine MOM_domains_init + +end module MOM_domain_init diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 73c5cc94e1..8034e19048 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -3,10 +3,10 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : chksum => rotated_field_chksum use MOM_domains, only : PE_here, num_PEs 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_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file use MOM_io, only : MOM_read_data, read_data, MOM_write_field, read_field_chksum @@ -14,9 +14,9 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +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 -use MOM_transform_FMS, only : chksum => rotated_mpp_chksum use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -874,7 +874,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! this should be 2 Gb or less. integer :: start_var, next_var ! The starting variables of the ! current and next files. - integer :: unit ! The mpp unit of the open file. + integer :: unit ! The I/O unit of the open file. integer :: m, nz, num_files, var_periods integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. @@ -1086,7 +1086,7 @@ subroutine restore_state(filename, directory, day, G, CS) integer :: sizes(7) integer :: ndim, nvar, natt, ntime, pos - integer :: unit(CS%max_fields) ! The mpp unit of all open files. + integer :: unit(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. @@ -1363,7 +1363,7 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous !! call to restart_init. integer, dimension(:), & - optional, intent(out) :: units !< The mpp units of all opened files. + optional, intent(out) :: units !< The I/O units of all opened files. character(len=*), dimension(:), & optional, intent(out) :: file_paths !< The full paths to open files. logical, dimension(:), & diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 index a6c28717b3..a4a3f7c2c4 100644 --- a/src/framework/MOM_transform_FMS.F90 +++ b/src/framework/MOM_transform_FMS.F90 @@ -3,28 +3,16 @@ module MOM_transform_FMS -use horiz_interp_mod, only : horiz_interp_type +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL -use mpp_mod, only : mpp_chksum +use horiz_interp_mod, only : horiz_interp_type use time_manager_mod, only : time_type use time_interp_external_mod, only : time_interp_external -use MOM_array_transform, only : allocate_rotated_array, rotate_array - implicit none ; private -public rotated_mpp_chksum public rotated_time_interp_external -!> Rotate and compute the FMS (mpp) checksum of a field -interface rotated_mpp_chksum - module procedure rotated_mpp_chksum_real_0d - module procedure rotated_mpp_chksum_real_1d - module procedure rotated_mpp_chksum_real_2d - module procedure rotated_mpp_chksum_real_3d - module procedure rotated_mpp_chksum_real_4d -end interface rotated_mpp_chksum - !> Read a field based on model time, and rotate to the model domain interface rotated_time_interp_external module procedure rotated_time_interp_external_0d @@ -37,122 +25,6 @@ module MOM_transform_FMS ! NOTE: No transformations are applied to the 0d and 1d field implementations, ! but are provided to maintain compatibility with the FMS interfaces. - -!> Compute the FMS (mpp) checksum of a scalar. -!! This function is provided to support the full FMS mpp_chksum interface. -function rotated_mpp_chksum_real_0d(field, pelist, mask_val, turns) & - result(chksum) - real, intent(in) :: field !> Input scalar - integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum - real, optional, intent(in) :: mask_val !> FMS mask value - integer, optional, intent(in) :: turns !> Number of quarter turns - integer :: chksum !> FMS checksum of scalar - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for 0d fields.") - - chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) -end function rotated_mpp_chksum_real_0d - - -!> Compute the FMS (mpp) checksum of a 1d field. -!! This function is provided to support the full FMS mpp_chksum interface. -function rotated_mpp_chksum_real_1d(field, pelist, mask_val, turns) & - result(chksum) - real, intent(in) :: field(:) !> Input field - integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum - real, optional, intent(in) :: mask_val !> FMS mask value - integer, optional, intent(in) :: turns !> Number of quarter-turns - integer :: chksum !> FMS checksum of field - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for 1d fields.") - - chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) -end function rotated_mpp_chksum_real_1d - - -!> Compute the FMS (mpp) checksum of a rotated 2d field. -function rotated_mpp_chksum_real_2d(field, pelist, mask_val, turns) & - result(chksum) - real, intent(in) :: field(:,:) !> Unrotated input field - integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum - real, optional, intent(in) :: mask_val !> FMS mask value - integer, optional, intent(in) :: turns !> Number of quarter-turns - integer :: chksum !> FMS checksum of field - - real, allocatable :: field_rot(:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) - else - call allocate_rotated_array(field, [1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) - deallocate(field_rot) - endif -end function rotated_mpp_chksum_real_2d - - -!> Compute the FMS (mpp) checksum of a rotated 3d field. -function rotated_mpp_chksum_real_3d(field, pelist, mask_val, turns) & - result(chksum) - real, intent(in) :: field(:,:,:) !> Unrotated input field - integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum - real, optional, intent(in) :: mask_val !> FMS mask value - integer, optional, intent(in) :: turns !> Number of quarter-turns - integer :: chksum !> FMS checksum of field - - real, allocatable :: field_rot(:,:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) - else - call allocate_rotated_array(field, [1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) - deallocate(field_rot) - endif -end function rotated_mpp_chksum_real_3d - - -!> Compute the FMS (mpp) checksum of a rotated 4d field. -function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & - result(chksum) - real, intent(in) :: field(:,:,:,:) !> Unrotated input field - integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum - real, optional, intent(in) :: mask_val !> FMS mask value - integer, optional, intent(in) :: turns !> Number of quarter-turns - integer :: chksum !> FMS checksum of field - - real, allocatable :: field_rot(:,:,:,:) - integer :: qturns - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) - else - call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) - deallocate(field_rot) - endif -end function rotated_mpp_chksum_real_4d - - !> Read a scalar field based on model time !! This function is provided to support the full FMS time_interp_external !! interface. From 81a6ff8ee8f197709fc8357271d907f4e759f7d1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 07:04:33 -0500 Subject: [PATCH 112/212] +Add explicit interface for field_exists to MOM_io Added an explicit interface for field_exists to MOM_io.F90, and added a new optional argument of a MOM_domain_type to field_exists. All answers are bitwise identical, and all previous calls still work exactly as before, but there is a new optional argument. --- src/framework/MOM_io.F90 | 24 +++++++++++++++---- .../lateral/MOM_tidal_forcing.F90 | 2 +- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index eda00bfda0..4e5cd621c4 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -15,9 +15,8 @@ module MOM_io use ensemble_manager_mod, only : get_ensemble_id use fms_mod, only : write_version_number, open_namelist_file, check_nml_error -use fms_io_mod, only : file_exist, field_size, read_data -use fms_io_mod, only : field_exists=>field_exist, io_infra_end=>fms_io_exit -use fms_io_mod, only : get_filename_appendix=>get_filename_appendix +use fms_io_mod, only : file_exist, field_exist, field_size, read_data +use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix use mpp_domains_mod, only : domain1d, domain2d, mpp_get_domain_components use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST use mpp_io_mod, only : open_file => mpp_open, close_file => mpp_close @@ -862,7 +861,7 @@ end function MOM_file_exists !> Returns true if the named file or its domain-decomposed variant exists. function FMS_file_exists(filename, domain, no_domain) - character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: filename !< The name of the file being inquired about type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition ! This function uses the fms_io function file_exist to determine whether @@ -874,6 +873,23 @@ function FMS_file_exists(filename, domain, no_domain) end function FMS_file_exists +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + if (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 !> This function uses the fms_io function read_data to read a scalar !! data field named "fieldname" from file "filename". diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 6064e27726..1f95cb5162 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -536,7 +536,7 @@ subroutine find_in_files(filenames, varname, array, G) do nf=1,size(filenames) if (LEN_TRIM(filenames(nf)) == 0) cycle - if (field_exists(filenames(nf), varname, G%Domain%mpp_domain)) then + if (field_exists(filenames(nf), varname, MOM_domain=G%Domain)) then call MOM_read_data(filenames(nf), varname, array, G%Domain) return endif From 37ef28bc0c32a4d20b92737b76fad2a2d9feadd4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 11:19:21 -0500 Subject: [PATCH 113/212] +Add get_domain_components to MOM_domains.F90 Added the new interface get_domain_components to MOM_domains.F90 to return the 1-d domains that are make up a 2-d domain, with overloaded variants working on MOM_domain_type or domain2D arguments. The MOM_domains module also now provides access to the domain2D type. All answers are bitwise identical. --- src/framework/MOM_domains.F90 | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index dc1f8ff867..cc33b238f4 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -15,7 +15,7 @@ module MOM_domains use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains -use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain +use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain, mpp_get_domain_components use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain use mpp_domains_mod, only : global_field_sum => mpp_global_sum @@ -37,7 +37,7 @@ module MOM_domains implicit none ; private public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 -public :: create_MOM_domain, clone_MOM_domain +public :: create_MOM_domain, clone_MOM_domain, get_domain_components public :: deallocate_MOM_domain, deallocate_domain_contents public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain public :: pass_var, pass_vector, PE_here, root_PE, num_PEs @@ -52,7 +52,7 @@ module MOM_domains public :: compute_block_extent, get_global_shape, get_layout_extents public :: MOM_thread_affinity_set, set_MOM_thread_affinity public :: get_simple_array_i_ind, get_simple_array_j_ind -public :: domain2D +public :: domain2D, domain1D !> Do a halo update on an array interface pass_var @@ -104,7 +104,12 @@ module MOM_domains module procedure clone_MD_to_MD, clone_MD_to_d2D end interface clone_MOM_domain -!> The MOM_domain_type contains information about the domain decompositoin. +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> The MOM_domain_type contains information about the domain decomposition. type, public :: MOM_domain_type type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. @@ -1709,6 +1714,24 @@ subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) !$ flush(6) end subroutine set_MOM_thread_affinity +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +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, & From 51720fb3357866ec5e6c09c1bee67759f7c7accb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 11:21:41 -0500 Subject: [PATCH 114/212] +Split MOM_io_wrapper.F90 out from MOM_io.F90 Created the new module MOM_io_wrapper from the contents of MOM_io, so that there are two separate modules, one of which use MOM-specific calls and structures, and another that directly calls or wraps the mpp and FMS I/O interfaces. All of the previous interfaces that were accessible via MOM_io are still being served from the this module, so no changes are needed outside of these two modules. All answers are bitwise identical. --- src/framework/MOM_io.F90 | 596 ++++--------------------------- src/framework/MOM_io_wrapper.F90 | 504 ++++++++++++++++++++++++++ 2 files changed, 565 insertions(+), 535 deletions(-) create mode 100644 src/framework/MOM_io_wrapper.F90 diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 4e5cd621c4..cbede5e3eb 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -3,51 +3,46 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_array_transform, only : allocate_rotated_array, rotate_array -use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE, get_domain_components +use MOM_domains, only : domain1D, get_simple_array_i_ind, get_simple_array_j_ind use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_io_wrapper, only : MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data +use MOM_io_wrapper, only : file_exists, field_exists, read_field_chksum +use MOM_io_wrapper, only : open_file, close_file, field_size, fieldtype, get_filename_appendix +use MOM_io_wrapper, only : flush_file, get_file_info, get_file_atts, get_file_fields +use MOM_io_wrapper, only : get_file_times, read_data, axistype, get_axis_data +use MOM_io_wrapper, only : write_field, write_metadata, write_version_number, get_ensemble_id +use MOM_io_wrapper, only : open_namelist_file, check_nml_error, io_infra_init, io_infra_end +use MOM_io_wrapper, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE +use MOM_io_wrapper, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_io_wrapper, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type -use ensemble_manager_mod, only : get_ensemble_id -use fms_mod, only : write_version_number, open_namelist_file, check_nml_error -use fms_io_mod, only : file_exist, field_exist, field_size, read_data -use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix -use mpp_domains_mod, only : domain1d, domain2d, mpp_get_domain_components -use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST -use mpp_io_mod, only : open_file => mpp_open, close_file => mpp_close -use mpp_io_mod, only : mpp_write_meta, write_field => mpp_write -use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist -use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data -use mpp_io_mod, only : mpp_get_fields, fieldtype, flush_file=>mpp_flush -use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII -use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF -use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY -use mpp_io_mod, only : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY -use mpp_io_mod, only : get_file_info=>mpp_get_info, get_file_atts=>mpp_get_atts -use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times -use mpp_io_mod, only : io_infra_init=>mpp_io_init - use iso_fortran_env, only : stdout_iso=>output_unit, stderr_iso=>error_unit -use netcdf +use netcdf, only : NF90_open, NF90_inquire, NF90_inq_varids, NF90_inquire_variable +use netcdf, only : NF90_Inquire_Dimension, NF90_max_name, NF90_max_var_dims +use netcdf, only : NF90_STRERROR, NF90_NOWRITE, NF90_NOERR implicit none ; private -public :: close_file, create_file, field_exists, field_size, fieldtype, get_filename_appendix +! These interfaces are actually implemented in this file. +public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init +public :: var_desc, modify_vardesc, query_vardesc +! The following are simple pass throughs of routines from MOM_io_wrapper or other modules +public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields public :: get_file_times, open_file, read_axis_data, read_data, read_field_chksum -public :: num_timelevels, MOM_read_data, MOM_read_vector, MOM_write_field, ensembler -public :: reopen_file, slasher, write_field, write_version_number, MOM_io_init +public :: MOM_read_data, MOM_read_vector, MOM_write_field, get_axis_data +public :: slasher, write_field, write_version_number public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end +! These are encoding constants. public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE public :: CENTER, CORNER, NORTH_FACE, EAST_FACE -public :: var_desc, modify_vardesc, query_vardesc, cmor_long_std -public :: get_axis_data !> Type for describing a variable, typically a tracer type, public :: vardesc @@ -64,36 +59,6 @@ module MOM_io !! convert from intensive to extensive end type vardesc -!> Indicate whether a file exists, perhaps with domain decomposition -interface file_exists - module procedure FMS_file_exists - module procedure MOM_file_exists -end interface - -!> Read a data field from a file -interface MOM_read_data - module procedure MOM_read_data_4d - module procedure MOM_read_data_3d - module procedure MOM_read_data_2d - module procedure MOM_read_data_1d - module procedure MOM_read_data_0d -end interface - -!> Write a registered field to an output file -interface MOM_write_field - module procedure MOM_write_field_4d - module procedure MOM_write_field_3d - module procedure MOM_write_field_2d - module procedure MOM_write_field_1d - module procedure MOM_write_field_0d -end interface MOM_write_field - -!> Read a pair of data fields representing the two components of a vector from a file -interface MOM_read_vector - module procedure MOM_read_vector_3d - module procedure MOM_read_vector_2d -end interface - integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit @@ -237,39 +202,36 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if (.not.domain_set) call MOM_error(FATAL, "create_file: "//& "An ocean_grid_type or dyn_horgrid_type is required to create a file with a horizontal coordinate.") - call mpp_get_domain_components(Domain%mpp_domain, x_domain, y_domain) + call get_domain_components(Domain, x_domain, y_domain) endif if ((use_layer .or. use_int) .and. .not.present(GV)) call MOM_error(FATAL, & "create_file: A vertical grid type is required to create a file with a vertical coordinate.") -! Specify all optional arguments to mpp_write_meta: name, units, longname, cartesian, calendar, sense, -! domain, data, min). Otherwise if optional arguments are added to mpp_write_meta the compiler may -! (and in case of GNU does) get confused and crash. if (use_lath) & - call mpp_write_meta(unit, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & - cartesian='Y', domain = y_domain, data=gridLatT(jsg:jeg)) + call write_metadata(unit, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & + cartesian='Y', domain=y_domain, data=gridLatT(jsg:jeg)) if (use_lonh) & - call mpp_write_meta(unit, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & - cartesian='X', domain = x_domain, data=gridLonT(isg:ieg)) + call write_metadata(unit, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & + cartesian='X', domain=x_domain, data=gridLonT(isg:ieg)) if (use_latq) & - call mpp_write_meta(unit, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & - cartesian='Y', domain = y_domain, data=gridLatB(JsgB:JegB)) + call write_metadata(unit, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & + cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB)) if (use_lonq) & - call mpp_write_meta(unit, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & - cartesian='X', domain = x_domain, data=gridLonB(IsgB:IegB)) + call write_metadata(unit, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & + cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB)) if (use_layer) & - call mpp_write_meta(unit, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & - longname="Layer "//trim(GV%zAxisLongName), cartesian='Z', & - sense=1, data=GV%sLayer(1:GV%ke)) + call write_metadata(unit, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & + longname="Layer "//trim(GV%zAxisLongName), cartesian='Z', & + sense=1, data=GV%sLayer(1:GV%ke)) if (use_int) & - call mpp_write_meta(unit, axis_int, name="Interface", units=trim(GV%zAxisUnits), & - longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & - sense=1, data=GV%sInterface(1:GV%ke+1)) + call write_metadata(unit, axis_int, name="Interface", units=trim(GV%zAxisUnits), & + longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & + sense=1, data=GV%sInterface(1:GV%ke+1)) if (use_time) then ; if (present(timeunit)) then ! Set appropriate units, depending on the value. @@ -287,9 +249,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit write(time_units,'(es8.2," s")') timeunit endif - call mpp_write_meta(unit, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') + call write_metadata(unit, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') else - call mpp_write_meta(unit, axis_time, name="Time", units="days", longname="Time",cartesian= 'T') + call write_metadata(unit, axis_time, name="Time", units="days", longname="Time", cartesian= 'T') endif ; endif if (use_periodic) then @@ -298,8 +260,8 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit ! Define a periodic axis with unit labels. allocate(period_val(num_periods)) do k=1,num_periods ; period_val(k) = real(k) ; enddo - call mpp_write_meta(unit, axis_periodic, name="Period", units="nondimensional", & - longname="Periods for cyclical varaiables", cartesian= 't', data=period_val) + call write_metadata(unit, axis_periodic, name="Period", units="nondimensional", & + longname="Periods for cyclical varaiables", cartesian='T', data=period_val) deallocate(period_val) endif @@ -336,14 +298,14 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select - pack = 1 + pack = 1 if (present(checksums)) then - call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack = pack, checksum=checksums(k,:)) + call write_metadata(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack, checksum=checksums(k,:)) else - call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack = pack) + call write_metadata(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack) endif enddo @@ -432,76 +394,21 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit call MOM_error(FATAL,"MOM_io: "//mesg) endif - if (nvar>0) call mpp_get_fields(unit,fields(1:nvar)) + if (nvar > 0) call get_file_fields(unit, fields(1:nvar)) - ! Check the field names... + ! Check for inconsistent field names... ! do i=1,nvar -! call mpp_get_field_atts(fields(i),name) -! !if (trim(name) /= trim(vars%name) then -! !write (mesg,'("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! filename,vars%name,name) -! !call MOM_error(NOTE,"MOM_io: "//mesg) +! 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 endif end subroutine reopen_file -!> Read the data associated with a named axis in a file -subroutine read_axis_data(filename, axis_name, var) - character(len=*), intent(in) :: filename !< Name of the file to read - character(len=*), intent(in) :: axis_name !< Name of the axis to read - real, dimension(:), intent(out) :: var !< The axis location data - - integer :: i,len,unit, ndim, nvar, natt, ntime - logical :: axis_found - type(axistype), allocatable :: axes(:) - type(axistype) :: time_axis - character(len=32) :: name, units - - call open_file(unit, trim(filename), action=READONLY_FILE, form=NETCDF_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) - -!Find the number of variables (nvar) in this file - call get_file_info(unit, ndim, nvar, natt, ntime) -! ------------------------------------------------------------------- -! Allocate space for the number of axes in the data file. -! ------------------------------------------------------------------- - allocate(axes(ndim)) - call mpp_get_axes(unit, axes, time_axis) - - axis_found = .false. - do i = 1, ndim - call get_file_atts(axes(i), name=name, len=len, units=units) - if (name == axis_name) then - axis_found = .true. - call get_axis_data(axes(i),var) - exit - endif - enddo - - if (.not.axis_found) call MOM_error(FATAL, "MOM_io read_axis_data: "//& - "Unable to find axis "//trim(axis_name)//" in file "//trim(filename)) - - deallocate(axes) - -end subroutine read_axis_data - -subroutine read_field_chksum(field, chksum, valid_chksum) - type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. - integer(kind=8), intent(out) :: chksum !< The checksum for the field. - logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. - ! Local variables - integer(kind=8), dimension(3) :: checksum_file - - checksum_file(:) = -1 - valid_chksum = mpp_attribute_exist(field, "checksum") - if (valid_chksum) then - call mpp_get_atts(field, checksum=checksum_file) - chksum = checksum_file(1) - else - chksum = -1 - endif -end subroutine read_field_chksum !> This function determines how many time levels a variable has. function num_timelevels(filename, varname, min_dims) result(n_time) @@ -526,8 +433,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,"num_timelevels: "//& - " Difficulties opening "//trim(filename)//" - "//& - trim(NF90_STRERROR(status))) + " Difficulties opening "//trim(filename)//" - "//trim(NF90_STRERROR(status))) return endif @@ -578,16 +484,14 @@ function num_timelevels(filename, varname, min_dims) result(n_time) if (.not.found) then call MOM_error(WARNING,"num_timelevels: "//& - " variable "//trim(varname)//" was not found in file "//& - trim(filename)) + " variable "//trim(varname)//" was not found in file "//trim(filename)) return endif status = nf90_inquire_variable(ncid, varid, ndims = ndims) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - trim(NF90_STRERROR(status))//" Getting number of dimensions of "//& - trim(varname)//" in "//trim(filename)) + call MOM_error(WARNING,"num_timelevels: "//trim(NF90_STRERROR(status))//& + " Getting number of dimensions of "//trim(varname)//" in "//trim(filename)) return endif @@ -604,9 +508,8 @@ function num_timelevels(filename, varname, min_dims) result(n_time) status = nf90_inquire_variable(ncid, varid, dimids = dimids(1:ndims)) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - trim(NF90_STRERROR(status))//" Getting last dimension ID for "//& - trim(varname)//" in "//trim(filename)) + call MOM_error(WARNING,"num_timelevels: "//trim(NF90_STRERROR(status))//& + " Getting last dimension ID for "//trim(varname)//" in "//trim(filename)) return endif @@ -615,8 +518,6 @@ function num_timelevels(filename, varname, min_dims) result(n_time) trim(NF90_STRERROR(status))//" Getting number of time levels of "//& trim(varname)//" in "//trim(filename)) - return - end function num_timelevels @@ -766,7 +667,6 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & end subroutine query_vardesc - !> Copies a string subroutine safe_string_copy(str1, str2, fieldnm, caller) character(len=*), intent(in) :: str1 !< The string being copied @@ -786,7 +686,6 @@ subroutine safe_string_copy(str1, str2, fieldnm, caller) str2 = trim(str1) end subroutine safe_string_copy - !> Returns a name with "%#E" or "%E" replaced with the ensemble member number. function ensembler(name, ens_no_in) result(en_nm) character(len=*), intent(in) :: name !< The name to be modified @@ -844,378 +743,6 @@ function ensembler(name, ens_no_in) result(en_nm) end function ensembler - -!> Returns true if the named file or its domain-decomposed variant exists. -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. - - logical :: MOM_file_exists - - MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) - -end function MOM_file_exists - -!> Returns true if the named file or its domain-decomposed variant exists. -function FMS_file_exists(filename, domain, no_domain) - character(len=*), intent(in) :: filename !< The name of the file being inquired about - type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition - logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition -! This function uses the fms_io function file_exist to determine whether -! a named file (or its decomposed variant) exists. - - logical :: FMS_file_exists - - FMS_file_exists = file_exist(filename, domain, no_domain) - -end function FMS_file_exists - -!> Field_exists returns true if the field indicated by field_name is present in the -!! file file_name. If file_name does not exist, it returns false. -function field_exists(filename, field_name, domain, no_domain, MOM_domain) - character(len=*), intent(in) :: filename !< The name of the file being inquired about - character(len=*), intent(in) :: field_name !< The name of the field being sought - type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition - logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition - type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - logical :: field_exists !< True if filename exists and field_name is in filename - - if (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 - -!> This function uses the fms_io function read_data to read a scalar -!! data field named "fieldname" from file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, 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, intent(inout) :: data !< The 1-dimensional array into which the data - integer, optional, intent(in) :: timelevel !< The time level in the file to read - real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before it is returned. - - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) - - if (present(scale)) then ; if (scale /= 1.0) then - data = scale*data - endif ; endif - -end subroutine MOM_read_data_0d - -!> This function uses the fms_io function read_data to read a 1-D -!! data field named "fieldname" from file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, 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 1-dimensional array into which the data - integer, optional, intent(in) :: timelevel !< The time level in the file to read - real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before they are returned. - - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) - - if (present(scale)) then ; if (scale /= 1.0) then - data(:) = scale*data(:) - endif ; endif - -end subroutine MOM_read_data_1d - -!> This function uses the fms_io function read_data to read a distributed -!! 2-D data field named "fieldname" from file "filename". Valid values for -!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. -subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, 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 2-dimensional array into which the data - !! should be read - type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - integer, optional, intent(in) :: timelevel !< The time level in the file to read - integer, optional, intent(in) :: position !< A flag indicating where this data is located - real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before it is returned. - - integer :: is, ie, js, je - - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) - - if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je) = scale*data(is:ie,js:je) - endif ; endif - -end subroutine MOM_read_data_2d - -!> This function uses the fms_io function read_data to read a distributed -!! 3-D data field named "fieldname" from file "filename". Valid values for -!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. -subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, 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 - type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - integer, optional, intent(in) :: timelevel !< The time level in the file to read - integer, optional, intent(in) :: position !< A flag indicating where this data is located - real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before it is returned. - - integer :: is, ie, js, je - - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) - - if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je,:) = scale*data(is:ie,js:je,:) - endif ; endif - -end subroutine MOM_read_data_3d - -!> This function uses the fms_io function 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. -subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & - timelevel, position, 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 4-dimensional array into which the data - !! should be read - type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - integer, optional, intent(in) :: timelevel !< The time level in the file to read - integer, optional, intent(in) :: position !< A flag indicating where this data is located - real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied - !! by before it is returned. - - integer :: is, ie, js, je - - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) - - if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je,:,:) = scale*data(is:ie,js:je,:,:) - endif ; endif - -end subroutine MOM_read_data_4d - - -!> This function uses the fms_io function read_data to read a pair of distributed -!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for -!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. -subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair, scale) - character(len=*), intent(in) :: filename !< The name of the file to read - character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file - character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file - real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the - !! u-component of the data should be read - real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the - !! v-component of the data should be read - type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - integer, optional, intent(in) :: timelevel !< The time level in the file to read - integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read - real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied - !! by before they are returned. - integer :: is, ie, js, je - integer :: u_pos, v_pos - - u_pos = EAST_FACE ; v_pos = NORTH_FACE - if (present(stagger)) then - if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE - elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER - elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif - endif - - 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) - - if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) - u_data(is:ie,js:je) = scale*u_data(is:ie,js:je) - call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) - v_data(is:ie,js:je) = scale*v_data(is:ie,js:je) - endif ; endif - -end subroutine MOM_read_vector_2d - - -!> This function uses the fms_io function read_data to read a pair of distributed -!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for -!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. -subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair, scale) - character(len=*), intent(in) :: filename !< The name of the file to read - character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file - character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file - real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the - !! u-component of the data should be read - real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the - !! v-component of the data should be read - type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - integer, optional, intent(in) :: timelevel !< The time level in the file to read - integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized - real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied - !! by before they are returned. - - integer :: is, ie, js, je - integer :: u_pos, v_pos - - u_pos = EAST_FACE ; v_pos = NORTH_FACE - if (present(stagger)) then - if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE - elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER - elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif - endif - - 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) - - if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) - u_data(is:ie,js:je,:) = scale*u_data(is:ie,js:je,:) - call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) - v_data(is:ie,js:je,:) = scale*v_data(is:ie,js:je,:) - endif ; endif - -end subroutine MOM_read_vector_3d - - -!> Write a 4d field to an output file, potentially with rotation -subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) - integer, intent(in) :: io_unit !< File I/O unit handle - 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 - 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, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field - - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) - integer, intent(in) :: io_unit !< File I/O unit handle - 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 - 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, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field - - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) - integer, intent(in) :: io_unit !< File I/O unit handle - 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 - 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, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field - - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, field, tstamp, fill_value) - integer, intent(in) :: io_unit !< File I/O unit handle - type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine MOM_write_field_1d - -!> Write a 0d field to an output file -subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) - integer, intent(in) :: io_unit !< File I/O unit handle - type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine MOM_write_field_0d - - !> Initialize the MOM_io module subroutine MOM_io_init(param_file) type(param_file_type), intent(in) :: param_file !< structure indicating the open file to @@ -1229,7 +756,6 @@ subroutine MOM_io_init(param_file) end subroutine MOM_io_init - !> \namespace mom_io !! !! This file contains a number of subroutines that manipulate diff --git a/src/framework/MOM_io_wrapper.F90 b/src/framework/MOM_io_wrapper.F90 new file mode 100644 index 0000000000..ed4405dbd9 --- /dev/null +++ b/src/framework/MOM_io_wrapper.F90 @@ -0,0 +1,504 @@ +!> This module contains a thin inteface to mpp and fms I/O code +module MOM_io_wrapper + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : allocate_rotated_array, rotate_array +use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING + +use ensemble_manager_mod, only : get_ensemble_id +use fms_mod, only : write_version_number, open_namelist_file, check_nml_error +use fms_io_mod, only : file_exist, field_exist, field_size, read_data +use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix +use mpp_domains_mod, only : domain2d, CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST +use mpp_io_mod, only : open_file=>mpp_open, close_file=>mpp_close +use mpp_io_mod, only : write_metadata=>mpp_write_meta, write_field=>mpp_write +use mpp_io_mod, only : get_field_atts=>mpp_get_atts, mpp_attribute_exist +use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data +use mpp_io_mod, only : mpp_get_fields, fieldtype, flush_file=>mpp_flush +use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII +use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF +use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY +use mpp_io_mod, only : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY +use mpp_io_mod, only : get_file_info=>mpp_get_info, get_file_atts=>mpp_get_atts +use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times +use mpp_io_mod, only : io_infra_init=>mpp_io_init + +implicit none ; private + +! These interfaces are actually implemented in this file. +public :: MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data +public :: file_exists, field_exists, read_field_chksum +! The following are simple pass throughs of routines from other modules. +public :: open_file, close_file, field_size, fieldtype, get_filename_appendix +public :: flush_file, get_file_info, get_file_atts, get_file_fields, get_field_atts +public :: get_file_times, read_data, axistype, get_axis_data +public :: write_field, write_metadata, write_version_number, get_ensemble_id +public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end +! These are encoding constants. +public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE +public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +!> Indicate whether a file exists, perhaps with domain decomposition +interface file_exists + module procedure FMS_file_exists + module procedure MOM_file_exists +end interface + +!> Read a data field from a file +interface MOM_read_data + module procedure MOM_read_data_4d + module procedure MOM_read_data_3d + module procedure MOM_read_data_2d + module procedure MOM_read_data_1d + module procedure MOM_read_data_0d +end interface + +!> Write a registered field to an output file +interface MOM_write_field + module procedure MOM_write_field_4d + module procedure MOM_write_field_3d + module procedure MOM_write_field_2d + module procedure MOM_write_field_1d + module procedure MOM_write_field_0d +end interface MOM_write_field + +!> Read a pair of data fields representing the two components of a vector from a file +interface MOM_read_vector + module procedure MOM_read_vector_3d + module procedure MOM_read_vector_2d +end interface + +contains + +!> Read the data associated with a named axis in a file +subroutine read_axis_data(filename, axis_name, var) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: axis_name !< Name of the axis to read + real, dimension(:), intent(out) :: var !< The axis location data + + integer :: i, len, unit, ndim, nvar, natt, ntime + logical :: axis_found + type(axistype), allocatable :: axes(:) + type(axistype) :: time_axis + character(len=32) :: name, units + + call open_file(unit, trim(filename), action=READONLY_FILE, form=NETCDF_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) + +!Find the number of variables (nvar) in this file + call get_file_info(unit, ndim, nvar, natt, ntime) +! ------------------------------------------------------------------- +! Allocate space for the number of axes in the data file. +! ------------------------------------------------------------------- + allocate(axes(ndim)) + call mpp_get_axes(unit, axes, time_axis) + + axis_found = .false. + do i = 1, ndim + call get_file_atts(axes(i), name=name, len=len, units=units) + if (name == axis_name) then + axis_found = .true. + call get_axis_data(axes(i), var) + exit + endif + enddo + + if (.not.axis_found) call MOM_error(FATAL, "MOM_io read_axis_data: "//& + "Unable to find axis "//trim(axis_name)//" in file "//trim(filename)) + + deallocate(axes) + +end subroutine read_axis_data + +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=8), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + ! Local variables + integer(kind=8), dimension(3) :: checksum_file + + checksum_file(:) = -1 + valid_chksum = mpp_attribute_exist(field, "checksum") + if (valid_chksum) then + call get_field_atts(field, checksum=checksum_file) + chksum = checksum_file(1) + else + chksum = -1 + endif +end subroutine read_field_chksum + + +!> Returns true if the named file or its domain-decomposed variant exists. +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. + + logical :: MOM_file_exists + + MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + +end function MOM_file_exists + +!> Returns true if the named file or its domain-decomposed variant exists. +function FMS_file_exists(filename, domain, no_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + logical :: FMS_file_exists + + FMS_file_exists = file_exist(filename, domain, no_domain) + +end function FMS_file_exists + +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + if (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 + +!> This function uses the fms_io function read_data to read a scalar +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, 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, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif + +end subroutine MOM_read_data_0d + +!> This function uses the fms_io function read_data to read a 1-D +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, 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 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + +end subroutine MOM_read_data_1d + +!> This function uses the fms_io function read_data to read a distributed +!! 2-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, 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 2-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + integer :: is, ie, js, je + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je) = scale*data(is:ie,js:je) + endif ; endif + +end subroutine MOM_read_data_2d + +!> This function uses the fms_io function read_data to read a distributed +!! 3-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, 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 + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + integer :: is, ie, js, je + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:) = scale*data(is:ie,js:je,:) + endif ; endif + +end subroutine MOM_read_data_3d + +!> This function uses the fms_io function 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. +subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, 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 4-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + integer :: is, ie, js, je + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:,:) = scale*data(is:ie,js:je,:,:) + endif ; endif + +end subroutine MOM_read_data_4d + + +!> This function uses the fms_io function read_data to read a pair of distributed +!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + integer :: is, ie, js, je + integer :: u_pos, v_pos + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + 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) + + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je) = scale*u_data(is:ie,js:je) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je) = scale*v_data(is:ie,js:je) + endif ; endif + +end subroutine MOM_read_vector_2d + +!> This function uses the fms_io function read_data to read a pair of distributed +!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + + integer :: is, ie, js, je + integer :: u_pos, v_pos + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + 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) + + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je,:) = scale*u_data(is:ie,js:je,:) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je,:) = scale*v_data(is:ie,js:je,:) + endif ; endif + +end subroutine MOM_read_vector_3d + + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=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_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_0d + +end module MOM_io_wrapper From 45d29a99caa03b803974f9986c25c765224374d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 18:26:24 -0500 Subject: [PATCH 115/212] +Added an explicit interface to open_file Added an explicit interface for open_file to MOM_io_wrapper.F90. This version only includes the optional arguments that are actually used in the MOM6 or SIS2 code, but adds a new optional MOM_domain_type argument. The optional arguments to mpp_open that are not being carried over to the new MOM interface pertain to archaic file formats and will never be used in MOM6. All answers are bitwise identical. --- src/framework/MOM_io.F90 | 4 ++-- src/framework/MOM_io_wrapper.F90 | 30 +++++++++++++++++++++++++++++- src/framework/MOM_restart.F90 | 3 +-- 3 files changed, 32 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index cbede5e3eb..2cdfcae4b9 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -138,7 +138,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if (one_file) then call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, threading=thread) else - call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, domain=Domain%mpp_domain) + call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, MOM_domain=Domain) endif ! Define the coordinates. @@ -377,7 +377,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit if (one_file) then call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, threading=thread) else - call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, domain=Domain%mpp_domain) + call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, MOM_domain=Domain) endif if (unit < 0) return diff --git a/src/framework/MOM_io_wrapper.F90 b/src/framework/MOM_io_wrapper.F90 index ed4405dbd9..7437b59db1 100644 --- a/src/framework/MOM_io_wrapper.F90 +++ b/src/framework/MOM_io_wrapper.F90 @@ -13,7 +13,7 @@ module MOM_io_wrapper use fms_io_mod, only : file_exist, field_exist, field_size, read_data use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix use mpp_domains_mod, only : domain2d, CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST -use mpp_io_mod, only : open_file=>mpp_open, close_file=>mpp_close +use mpp_io_mod, only : mpp_open, close_file=>mpp_close use mpp_io_mod, only : write_metadata=>mpp_write_meta, write_field=>mpp_write use mpp_io_mod, only : get_field_atts=>mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data @@ -160,6 +160,34 @@ function FMS_file_exists(filename, domain, no_domain) end function FMS_file_exists +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domain, MOM_domain) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< 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, file, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) + else + call mpp_open(unit, file, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=domain) + endif +end subroutine open_file + !> Field_exists returns true if the field indicated by field_name is present in the !! file file_name. If file_name does not exist, it returns false. function field_exists(filename, field_name, domain, no_domain, MOM_domain) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 8034e19048..e376d9917b 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1451,8 +1451,7 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & ! Look for decomposed files using the I/O Layout. fexists = file_exists(filepath, G%Domain) if (fexists .and. (present(units))) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & - domain=G%Domain%mpp_domain) + call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, MOM_domain=G%Domain) if (fexists .and. present(global_files)) global_files(n) = .false. endif From e1ca9a905334880ff720111b15c069f9ad70841d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Jan 2021 21:32:15 -0500 Subject: [PATCH 116/212] Doxygen comments for get_layout_extents arguments Added doxygen comments describing two arguments to get_layout_extents. All answers are bitwise identical. --- src/framework/MOM_domains.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index cc33b238f4..65e7337964 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -2115,8 +2115,10 @@ end subroutine get_global_shape !! they are effectively intent out despite their declared intent of inout. subroutine get_layout_extents(Domain, extent_i, extent_j) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information - integer, dimension(:), allocatable, intent(inout) :: extent_i - integer, dimension(:), allocatable, intent(inout) :: extent_j + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout if (allocated(extent_i)) deallocate(extent_i) if (allocated(extent_j)) deallocate(extent_j) From dc7476755e65e8d594f2cc8913c6b8b23b69a80b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 11 Jan 2021 21:58:42 -0500 Subject: [PATCH 117/212] Adds targets check_mom6_api_nuopc, check_mom6_api_coupled - Allows us to check that we have not broken the ability to compile with the NUOPC, MCT or coupled_driver modules. - This is not a complete compile but only upto the last module that does not need anything other than MOM6 objects. --- .testing/Makefile | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/.testing/Makefile b/.testing/Makefile index 33d3ea4c4e..a780f19323 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -328,6 +328,40 @@ $(DEPS)/Makefile: ../ac/deps/Makefile mkdir -p $(@D) cp $< $@ +#--- +# The following block does a non-library build of a coupled driver interface to MOM, along with everything below it. +# This simply checks that we have not 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 +MK_TEMPLATE ?= ../../$(DEPS)/mkmf/templates/ncrc-gnu.mk +# NUOPC driver +build/nuopc/Makefile: ../config_src/nuopc_driver $(MOM_SOURCE) + mkdir -p $(@D) + cd $(@D) \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/nuopc_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names +build/nuopc/mom_ocean_model_nuopc.o: build/nuopc/Makefile + cd $(@D) && make $(@F) +check_mom6_api_nuopc: build/nuopc/mom_ocean_model_nuopc.o +# GFDL coupled driver +build/coupled/Makefile: ../config_src/coupled_driver $(MOM_SOURCE) + mkdir -p $(@D) + cd $(@D) \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/coupled_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names +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/Makefile: ../config_src/mct_driver $(MOM_SOURCE) + mkdir -p $(@D) + cd $(@D) \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/mct_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ + && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names +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 #--- # Python preprocessing From 5c93def092eae6f06df4cd94bc44de23550cf36d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 12 Jan 2021 14:14:21 -0500 Subject: [PATCH 118/212] MOM_hor_visc: horizontal_viscosity loop reorder This patch reorders many of the loops in horizontal_viscosity in order to improve vectorization of the Laplacian and biharmonic viscosities. Specifically, a single loop containing many different computations were broken up into many loops of individual operations. This patch required introduction of several new 2D arrays. On Gaea's Broadwell CPUs (E5-2697 v4), this is a ~80% speedup on a 32x32x75 `benchmark` configuration. Smaller speedups were observed on AMD processors. On the Gaea nodes, performance appears to be limited by the very large number of variables in the function stack, and the high degree of stack spill. Further loop reordering may cause slowdowns unless the stack usage is reduced. No answers should be changed by this patch, but deserves extra scrutiny given the fundamental role of this function in nearly all simulations. --- .../lateral/MOM_hor_visc.F90 | 689 ++++++++++++------ 1 file changed, 463 insertions(+), 226 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index ed3ef7173e..06a6269dc5 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -196,7 +196,6 @@ module MOM_hor_visc integer :: id_normstress = -1, id_shearstress = -1 !>@} - end type hor_visc_CS contains @@ -265,8 +264,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] - ! Leith_Kh_h, & ! Leith Laplacian viscosity at h-points [L2 T-1 ~> m2 s-1] - ! Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [L4 T-1 ~> m4 s-1] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] @@ -289,7 +286,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] 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, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] Leith_Kh_q, & ! Leith Laplacian viscosity at q-points [L2 T-1 ~> m2 s-1] Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] @@ -297,8 +294,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] - 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. + 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. grad_vel_mag_bt_q, & ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] @@ -323,30 +320,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, div_xx_h, & ! horizontal divergence [T-1 ~> s-1] sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] NoSt ! A diagnostic array of normal stress [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - 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] - real :: Ah ! biharmonic viscosity [L4 T-1 ~> m4 s-1] - real :: Kh ! Laplacian viscosity [L2 T-1 ~> m2 s-1] + 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] real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: mod_Leith ! nondimensional coefficient for divergence part of modified Leith ! viscosity. Here set equal to nondimensional Laplacian Leith constant. ! This is set equal to zero if modified Leith is not used. - real :: Shear_mag ! magnitude of the shear [T-1 ~> s-1] - real :: vert_vort_mag ! magnitude of the vertical vorticity gradient [L-1 T-1 ~> m-1 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] real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4]. 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_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 :: hrat_min ! minimum thicknesses at the 4 neighboring - ! velocity points divided by the thickness at the stress - ! point (h or q point) [nondim] - real :: visc_bound_rem ! fraction of overall viscous bounds that - ! remain to be applied [nondim] + real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] real :: Kh_scale ! A factor between 0 and 1 by which the horizontal ! Laplacian viscosity is rescaled [nondim] real :: RoScl ! The scaling function for MEKE source term [nondim] @@ -365,6 +357,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] 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 :: 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] + real :: grid_Ah ! Biharmonic viscosity bound by grid [L4 T-1 ~> m4 s-1] logical :: rescale_Kh, legacy_bound logical :: find_FrictWork @@ -374,6 +373,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 + + ! Fields evaluated on active layers, used for constructing 3D stress fields + ! NOTE: The position of these declarations can impact performance, due to the + ! very large number of stack arrays in this function. Move with caution! + real, dimension(SZIB_(G),SZJB_(G)) :: & + Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] + Kh, & ! Laplacian viscosity [L2 T-1 ~> m2 s-1] + Shear_mag, & ! magnitude of the shear [T-1 ~> s-1] + vert_vort_mag, & ! magnitude of the vertical vorticity gradient [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 [nondim] + 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 @@ -383,9 +394,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 - Ah_h(:,:,:) = 0.0 - Kh_h(:,:,:) = 0.0 - 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. @@ -505,10 +513,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & - !$OMP grad_vort_mag_h_2d, grad_vort_mag_q_2d, & + !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & !$OMP grad_vel_mag_h, grad_vel_mag_q, & !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & - !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & + !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & + !$OMP sh_xx_sq, sh_xy_sq, grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & @@ -519,22 +528,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! shearing strain advocated by Smagorinsky (1993) and discussed in ! Griffies and Hallberg (2000). - ! Calculate horizontal tension - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 + ! Calculate horizontal tension dudx(i,j) = CS%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) = CS%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) - if (CS%id_normstress > 0) NoSt(i,j,k) = sh_xx(i,j) - enddo ; enddo - ! Components for the shearing strain - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + ! Components for the shearing strain 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%id_normstress > 0) then + do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 + NoSt(i,j,k) = sh_xx(i,j) + enddo ; enddo + endif + ! Interpolate the thicknesses to velocity points. ! The extra wide halos are to accommodate the cross-corner-point projections ! in OBCs, which are not ordinarily be necessary, and might not be necessary @@ -608,7 +620,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then ! There are extra wide halos here to accommodate the cross-corner-point ! OBC projections, but they might not be necessary if the accelerations @@ -765,7 +776,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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=js-1,Jeq ; do I=is-1,Ieq do j=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+1 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) @@ -828,133 +838,247 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, meke_res_fn = 1. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then - Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & - 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & - (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) + if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + sh_xx_sq = sh_xx(i,j) * sh_xx(i,j) + sh_xy_sq = 0.25 * ( & + (sh_xy(I-1,J-1) * sh_xy(I-1,J-1) + sh_xy(I,J) * sh_xy(I,J)) & + + (sh_xy(I-1,J) * sh_xy(I-1,J) + sh_xy(I,J-1) * sh_xy(I,J-1)) & + ) + Shear_mag(i,j) = sqrt(sh_xx_sq + sh_xy_sq) + enddo ; enddo + endif + + if (CS%better_bound_Ah .or. CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 + visc_bound_rem(i,j) = 1.0 + enddo ; enddo endif + endif + + if (CS%Laplacian) then if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then - vert_vort_mag = MIN(grad_vort_mag_h(i,j) + grad_div_mag_h(i,j),3.*grad_vort_mag_h_2d(i,j)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 - vert_vort_mag = (grad_vort_mag_h(i,j) + grad_div_mag_h(i,j)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + vert_vort_mag(i,j) = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) + enddo ; enddo endif endif - if (CS%better_bound_Ah .or. CS%better_bound_Kh) then - hrat_min = min(1.0, min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) / & - (h(i,j,k) + h_neglect) ) - visc_bound_rem = 1.0 - endif - if (CS%Laplacian) then - ! Determine the Laplacian viscosity at h points, using the - ! largest value from several parameterizations. - Kh = CS%Kh_bg_xx(i,j) ! Static (pre-computed) background viscosity + ! 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) + enddo ; enddo + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if (CS%add_LES_viscosity) then - if (CS%Smagorinsky_Kh) Kh = Kh + CS%Laplac2_const_xx(i,j) * Shear_mag - if (CS%Leith_Kh) Kh = Kh + CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3 + if (CS%Smagorinsky_Kh) & + Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) + if (CS%Leith_Kh) & + Kh(i,j) = Kh(i,j) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3 else - if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xx(i,j) * Shear_mag ) - if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3) + if (CS%Smagorinsky_Kh) & + Kh(i,j) = max(Kh(i,j), CS%Laplac2_const_xx(i,j) * Shear_mag(i,j)) + if (CS%Leith_Kh) & + Kh(i,j) = max(Kh(i,j), CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3) endif - ! All viscosity contributions above are subject to resolution scaling - if (rescale_Kh) Kh = VarMix%Res_fn_h(i,j) * Kh - if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_h(i,j) + enddo ; enddo + + ! All viscosity contributions above are subject to resolution scaling + + if (rescale_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 - if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xx(i,j)) - Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 + Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) + enddo ; enddo + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_h(i,j) + if (use_MEKE_Ku) & - Kh = Kh + MEKE%Ku(i,j) * meke_res_fn ! *Add* the MEKE contribution (might be negative) - if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * ( 1. - CS%n1n2_h(i,j)**2 ) ! *Add* the tension component - ! of anisotropic viscosity + ! *Add* the MEKE contribution (might be negative) + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * meke_res_fn + enddo ; enddo - ! Newer method of bounding for stability + if (CS%anisotropic) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! *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 + endif + + ! Newer method of bounding for stability + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if (CS%better_bound_Kh) then - if (Kh >= hrat_min*CS%Kh_Max_xx(i,j)) then - visc_bound_rem = 0.0 - Kh = hrat_min*CS%Kh_Max_xx(i,j) + 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) else - visc_bound_rem = 1.0 - Kh / (hrat_min*CS%Kh_Max_xx(i,j)) + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) endif endif + enddo ; enddo - if ((CS%id_Kh_h>0) .or. find_FrictWork .or. CS%debug) Kh_h(i,j,k) = Kh + 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) + enddo ; enddo + endif - if (CS%id_grid_Re_Kh>0) then + if (CS%id_grid_Re_Kh>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) - grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) & - / max(Kh, CS%min_grid_Kh) - endif + 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 + enddo ; enddo + endif - if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) - if (CS%id_sh_xx_h>0) sh_xx_h(i,j,k) = sh_xx(i,j) + 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) + enddo ; enddo + endif + + if (CS%id_sh_xx_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + sh_xx_h(i,j,k) = sh_xx(i,j) + enddo ; enddo + endif - str_xx(i,j) = -Kh * sh_xx(i,j) - else ! not Laplacian + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = -Kh(i,j) * sh_xx(i,j) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = 0.0 - endif ! Laplacian + enddo ; enddo + endif - if (CS%anisotropic) then + if (CS%anisotropic) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ! Shearing-strain averaged to h-points local_strain = 0.25 * ( (sh_xy(I,J) + sh_xy(I-1,J-1)) + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) ! *Add* the shear-strain contribution to the xx-component of stress str_xx(i,j) = str_xx(i,j) - CS%Kh_aniso * CS%n1n2_h(i,j) * CS%n1n1_m_n2n2_h(i,j) * local_strain - endif + enddo ; enddo + endif - if (CS%biharmonic) then - ! Determine the biharmonic viscosity at h points, using the - ! largest value from several parameterizations. - AhSm = 0.0; AhLth = 0.0 - if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then - if (CS%Smagorinsky_Ah) then - if (CS%bound_Coriolis) then - AhSm = Shear_mag * (CS%Biharm_const_xx(i,j) + & - CS%Biharm_const2_xx(i,j)*Shear_mag) - else - AhSm = CS%Biharm_const_xx(i,j) * Shear_mag - endif - endif - if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 - Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm), AhLth) - if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & - Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) - else - Ah = CS%Ah_bg_xx(i,j) - endif ! Smagorinsky_Ah or Leith_Ah + if (CS%biharmonic) then + ! Determine the biharmonic viscosity at h points, using the + ! largest value from several parameterizations. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = CS%Ah_bg_xx(i,j) + enddo ; enddo - if (use_MEKE_Au) Ah = Ah + MEKE%Au(i,j) ! *Add* the MEKE contribution + if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then + if (CS%Smagorinsky_Ah) then + if (CS%bound_Coriolis) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 + AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j) + Ah(i,j) = max(Ah(i,j), AhSm) + enddo ; enddo + endif + endif - if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - Ah = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + if (CS%Leith_Ah) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 + Ah(i,j) = max(Ah(i,j), AhLth) + enddo ; enddo endif - if (CS%better_bound_Ah) then - Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xx(i,j)) + 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 - if ((CS%id_Ah_h>0) .or. find_FrictWork .or. CS%debug) Ah_h(i,j,k) = Ah + if (use_MEKE_Au) then + ! *Add* the MEKE contribution + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = Ah(i,j) + MEKE%Au(i,j) + enddo ; enddo + endif - if (CS%id_grid_Re_Ah>0) then + if (CS%Re_Ah > 0.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) - grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) & - / max(Ah, CS%min_grid_Ah) + Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + enddo ; enddo + endif + + if (CS%better_bound_Ah) then + if (CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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 + Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xx(i,j)) + enddo ; enddo endif + endif - str_xx(i,j) = str_xx(i,j) + Ah * & - (CS%DY_dxT(i,j) * (G%IdyCu(I,j)*Del2u(I,j) - G%IdyCu(I-1,j)*Del2u(I-1,j)) - & - CS%DX_dyT(i,j) * (G%IdxCv(i,J)*Del2v(i,J) - G%IdxCv(i,J-1)*Del2v(i,J-1))) + if ((CS%id_Ah_h>0) .or. CS%debug) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = Ah(i,j) + enddo ; enddo + endif - ! Keep a copy of the biharmonic contribution for backscatter parameterization - bhstr_xx(i,j) = Ah * & - (CS%DY_dxT(i,j) * (G%IdyCu(I,j)*Del2u(I,j) - G%IdyCu(I-1,j)*Del2u(I-1,j)) - & - CS%DX_dyT(i,j) * (G%IdxCv(i,J)*Del2v(i,J) - G%IdxCv(i,J-1)*Del2v(i,J-1))) - bhstr_xx(i,j) = bhstr_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) + 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) + 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 + enddo ; enddo + endif - endif ! biharmonic + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + d_del2u = G%IdyCu(I,j) * Del2u(I,j) - G%IdyCu(I-1,j) * Del2u(I-1,j) + d_del2v = G%IdxCv(i,J) * Del2v(i,J) - G%IdxCv(i,J-1) * Del2v(i,J-1) + d_str = Ah(i,j) * (CS%DY_dxT(i,j) * d_del2u - CS%DX_dyT(i,j) * d_del2v) - enddo ; enddo + str_xx(i,j) = str_xx(i,j) + d_str + + ! 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 if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term @@ -989,147 +1113,259 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, meke_res_fn = 1. + if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then + do J=js-1,Jeq ; do I=is-1,Ieq + sh_xy_sq = sh_xy(I,J) * sh_xy(I,J) + sh_xx_sq = 0.25 * ( & + (sh_xx(i,j) * sh_xx(i,j) + sh_xx(i+1,j+1) * sh_xx(i+1,j+1)) & + + (sh_xx(i,j+1) * sh_xx(i,j+1) + sh_xx(i+1,j) * sh_xx(i+1,j)) & + ) + Shear_mag(i,j) = sqrt(sh_xy_sq + sh_xx_sq) + enddo ; enddo + endif + do J=js-1,Jeq ; do I=is-1,Ieq - if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then - Shear_mag = sqrt(sh_xy(I,J)*sh_xy(I,J) + & - 0.25*((sh_xx(i,j)*sh_xx(i,j) + sh_xx(i+1,j+1)*sh_xx(i+1,j+1)) + & - (sh_xx(i,j+1)*sh_xx(i,j+1) + sh_xx(i+1,j)*sh_xx(i+1,j)))) + 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 + + if (CS%better_bound_Ah .or. CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + h_min = min(h_u(I,j), h_u(I,j+1), h_v(i,J), h_v(i+1,J)) + hrat_min(i,j) = min(1.0, h_min / (hq(I,J) + h_neglect)) + enddo ; enddo + + if (CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + visc_bound_rem(i,j) = 1.0 + enddo ; enddo endif + endif + + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq + if (CS%no_slip .and. (G%mask2dBu(I,J) < 0.5)) then + if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then + ! This is a coastal vorticity point, so modify hq and hrat_min. + + hu = G%mask2dCu(I,j) * h_u(I,j) + G%mask2dCu(I,j+1) * h_u(I,j+1) + hv = G%mask2dCv(i,J) * h_v(i,J) + G%mask2dCv(i+1,J) * h_v(i+1,J) + if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) * & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) == 0.0) then + ! Only one of hu and hv is nonzero, so just add them. + hq(I,J) = hu + hv + hrat_min(i,j) = 1.0 + else + ! Both hu and hv are nonzero, so take the harmonic mean. + hq(I,J) = 2.0 * (hu * hv) / ((hu + hv) + h_neglect) + hrat_min(i,j) = min(1.0, min(hu, hv) / (hq(I,J) + h_neglect) ) + endif + endif + endif + enddo ; enddo + endif + + if (CS%Laplacian) then if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then - vert_vort_mag = MIN(grad_vort_mag_q(I,J) + grad_div_mag_q(I,J), 3.*grad_vort_mag_q_2d(I,J)) + do J=js-1,Jeq ; do I=is-1,Ieq + grad_vort = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) + grad_vort_qg = 3. * grad_vort_mag_q_2d(I,J) + vert_vort_mag(i,j) = min(grad_vort, grad_vort_qg) + enddo ; enddo else - vert_vort_mag = (grad_vort_mag_q(I,J) + grad_div_mag_q(I,J)) + do J=js-1,Jeq ; do I=is-1,Ieq + vert_vort_mag(i,j) = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) + enddo ; enddo endif endif - 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)))) - - if (CS%better_bound_Ah .or. CS%better_bound_Kh) then - hrat_min = min(1.0, min(h_u(I,j), h_u(I,j+1), h_v(i,J), h_v(i+1,J)) / & - (hq(I,J) + h_neglect) ) - visc_bound_rem = 1.0 - endif - if (CS%no_slip .and. (G%mask2dBu(I,J) < 0.5)) then - if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + & - (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then - ! This is a coastal vorticity point, so modify hq and hrat_min. - - hu = G%mask2dCu(I,j) * h_u(I,j) + G%mask2dCu(I,j+1) * h_u(I,j+1) - hv = G%mask2dCv(i,J) * h_v(i,J) + G%mask2dCv(i+1,J) * h_v(i+1,J) - if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) * & - (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) == 0.0) then - ! Only one of hu and hv is nonzero, so just add them. - hq(I,J) = hu + hv - hrat_min = 1.0 - else - ! Both hu and hv are nonzero, so take the harmonic mean. - hq(I,J) = 2.0 * (hu * hv) / ((hu + hv) + h_neglect) - hrat_min = min(1.0, min(hu, hv) / (hq(I,J) + h_neglect) ) - 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) + enddo ; enddo + + if (CS%Smagorinsky_Kh) then + if (CS%add_LES_viscosity) then + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(i,j) = max(Kh(i,j), CS%Laplac2_const_xy(I,J) * Shear_mag(i,j) ) + enddo ; enddo endif endif - if (CS%Laplacian) then - ! Determine the Laplacian viscosity at q points, using the - ! largest value from several parameterizations. - Kh = CS%Kh_bg_xy(i,j) ! Static (pre-computed) background viscosity + if (CS%Leith_Kh) then if (CS%add_LES_viscosity) then - if (CS%Smagorinsky_Kh) Kh = Kh + CS%Laplac2_const_xx(i,j) * Shear_mag - if (CS%Leith_Kh) Kh = Kh + CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3 + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(i,j) = Kh(i,j) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3 + enddo ; enddo else - if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xy(I,J) * Shear_mag ) - if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xy(I,J) * vert_vort_mag*inv_PI3) + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(i,j) = max(Kh(i,j), CS%Laplac3_const_xy(I,J) * vert_vort_mag(i,j) * inv_PI3) + enddo ; enddo endif - ! All viscosity contributions above are subject to resolution scaling - if (rescale_Kh) Kh = VarMix%Res_fn_q(i,j) * Kh - if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(i,j) + endif + + ! All viscosity contributions above are subject to resolution scaling + + do J=js-1,Jeq ; do I=is-1,Ieq + ! NOTE: The following do-block can be decomposed and vectorized, but + ! appears to cause slowdown on some machines. Evidence suggests that + ! this is caused by excessive spilling of stack variables. + ! TODO: Vectorize these loops after stack usage has been reduced.. + + if (rescale_Kh) & + Kh(i,j) = VarMix%Res_fn_q(i,j) * Kh(i,j) + + if (CS%res_scale_MEKE) & + meke_res_fn = VarMix%Res_fn_q(i,j) + ! Older method of bounding for stability - if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xy(i,j)) - Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. - if (use_MEKE_Ku) then ! *Add* the MEKE contribution (might be negative) - Kh = Kh + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & + if (legacy_bound) & + Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xy(i,j)) + + Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. + + if (use_MEKE_Ku) then + ! *Add* the MEKE contribution (might be negative) + Kh(i,j) = Kh(i,j) + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn endif + ! Older method of bounding for stability - if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! *Add* the shear component - ! of anisotropic viscosity + if (CS%anisotropic) & + ! *Add* the shear component of anisotropic viscosity + Kh(i,j) = Kh(i,j) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! Newer method of bounding for stability if (CS%better_bound_Kh) then - if (Kh >= hrat_min*CS%Kh_Max_xy(I,J)) then - visc_bound_rem = 0.0 - Kh = hrat_min*CS%Kh_Max_xy(I,J) + if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xy(I,J)) then + visc_bound_rem(i,j) = 0.0 + Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xy(I,J) elseif (CS%Kh_Max_xy(I,J)>0.) then - visc_bound_rem = 1.0 - Kh / (hrat_min*CS%Kh_Max_xy(I,J)) + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xy(I,J)) endif endif - if (CS%id_Kh_q>0 .or. CS%debug) Kh_q(I,J,k) = Kh - if (CS%id_vort_xy_q>0) vort_xy_q(I,J,k) = vort_xy(I,J) - if (CS%id_sh_xy_q>0) sh_xy_q(I,J,k) = sh_xy(I,J) + if (CS%id_Kh_q>0 .or. CS%debug) & + Kh_q(I,J,k) = Kh(i,j) - str_xy(I,J) = -Kh * sh_xy(I,J) - else ! not Laplacian - str_xy(I,J) = 0.0 - endif ! Laplacian + if (CS%id_vort_xy_q>0) & + vort_xy_q(I,J,k) = vort_xy(I,J) - if (CS%anisotropic) then + if (CS%id_sh_xy_q>0) & + 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 + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = 0. + enddo ; enddo + endif + + if (CS%anisotropic) then + do J=js-1,Jeq ; do I=is-1,Ieq ! Horizontal-tension averaged to q-points local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) ) ! *Add* the tension contribution to the xy-component of stress str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(i,j) * CS%n1n1_m_n2n2_q(i,j) * local_strain - endif + enddo ; enddo + endif - if (CS%biharmonic) then + if (CS%biharmonic) then ! Determine the biharmonic viscosity at q points, using the ! largest value from several parameterizations. - AhSm = 0.0 ; AhLth = 0.0 - if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then - if (CS%Smagorinsky_Ah) then - if (CS%bound_Coriolis) then - AhSm = Shear_mag * (CS%Biharm_const_xy(I,J) + & - CS%Biharm_const2_xy(I,J)*Shear_mag) - else - AhSm = CS%Biharm_const_xy(I,J) * Shear_mag - endif - endif - if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 - Ah = MAX(MAX(CS%Ah_bg_xy(I,J), AhSm), AhLth) - if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & - Ah = MIN(Ah, CS%Ah_Max_xy(I,J)) - else - Ah = CS%Ah_bg_xy(I,J) - endif ! Smagorinsky_Ah or Leith_Ah + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(i,j) = CS%Ah_bg_xy(I,J) + enddo ; enddo - if (use_MEKE_Au) then ! *Add* the MEKE contribution - Ah = Ah + 0.25*( (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + & - (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) + if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then + if (CS%Smagorinsky_Ah) then + if (CS%bound_Coriolis) then + do J=js-1,Jeq ; do I=is-1,Ieq + AhSm = Shear_mag(i,j) * (CS%Biharm_const_xy(I,J) & + + CS%Biharm_const2_xy(I,J) * Shear_mag(i,j) & + ) + Ah(i,j) = max(Ah(I,J), AhSm) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(i,j) + Ah(i,j) = max(Ah(I,J), AhSm) + enddo ; enddo + endif endif - if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) - Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + if (CS%Leith_Ah) then + do J=js-1,Jeq ; do I=is-1,Ieq + AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 + Ah(i,j) = max(Ah(I,J), AhLth) + enddo ; enddo endif - if (CS%better_bound_Ah) then - Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xy(I,J)) + if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xy(I,J)) + enddo ; enddo endif + endif ! Smagorinsky_Ah or Leith_Ah - if (CS%id_Ah_q>0 .or. CS%debug) Ah_q(I,J,k) = Ah + if (use_MEKE_Au) then + ! *Add* the MEKE contribution + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(i,j) = Ah(i,j) + 0.25 * ( & + (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) & + ) + enddo ; enddo + endif - str_xy(I,J) = str_xy(I,J) + Ah * ( dDel2vdx(I,J) + dDel2udy(I,J) ) + if (CS%Re_Ah > 0.0) then + do J=js-1,Jeq ; do I=is-1,Ieq + KE = 0.125 * ((u(I,j,k) + u(I,j+1,k))**2 + (v(i,J,k) + v(i+1,J,k))**2) + Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + enddo ; enddo + endif - ! Keep a copy of the biharmonic contribution for backscatter parameterization - bhstr_xy(I,J) = Ah * ( dDel2vdx(I,J) + dDel2udy(I,J) ) * & - (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) + if (CS%better_bound_Ah) then + if (CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xy(I,J)) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xy(I,J)) + enddo ; enddo + endif + endif - endif ! biharmonic + 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) + enddo ; enddo + endif - enddo ; enddo + ! Again, need to initialize str_xy as if its biharmonic + do J=js-1,Jeq ; do I=is-1,Ieq + d_str = Ah(i,j) * (dDel2vdx(I,J) + dDel2udy(I,J)) + + str_xy(I,J) = str_xy(I,J) + d_str + + ! 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 if (CS%use_GME) then call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) @@ -1197,14 +1433,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - if (CS%no_slip) then + 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)) - else + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = str_xy(I,J) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) - endif - enddo ; enddo - + enddo ; enddo + endif endif ! use_GME ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. @@ -1214,8 +1451,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & CS%dx2q(I,J) *str_xy(I,J))) * & G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) - enddo ; enddo + if (apply_OBC) then ! This is not the right boundary condition. If all the masking of tendencies are done ! correctly later then eliminating this block should not change answers. @@ -1237,6 +1474,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, CS%dx2h(i,j+1)*str_xx(i,j+1))) * & G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) enddo ; enddo + if (apply_OBC) then ! This is not the right boundary condition. If all the masking of tendencies are done ! correctly later then eliminating this block should not change answers. @@ -1288,28 +1526,27 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=js,je ; do i=is,ie FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) - Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & + Shear_mag_bc = sqrt(sh_xx(i,j) * sh_xx(i,j) + & 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) if (CS%answers_2018) then FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n ! Note the hard-coded dimensional constant in the following line that can not ! be rescaled for dimensional consistency. - Shear_mag = ( ( (US%s_to_T*Shear_mag)**MEKE%backscatter_Ro_pow ) + 1.e-30 ) & + Shear_mag_bc = (((US%s_to_T * Shear_mag_bc)**MEKE%backscatter_Ro_pow) + 1.e-30) & * MEKE%backscatter_Ro_c ! c * D^n ! The Rossby number function is g(Ro) = 1/(1+c.Ro^n) ! RoScl = 1 - g(Ro) - RoScl = Shear_mag / ( FatH + Shear_mag ) ! = 1 - f^n/(f^n+c*D^n) + RoScl = Shear_mag_bc / (FatH + Shear_mag_bc) ! = 1 - f^n/(f^n+c*D^n) else - if (FatH <= backscat_subround*Shear_mag) then + if (FatH <= backscat_subround*Shear_mag_bc) then RoScl = 1.0 else - Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag / FatH)**MEKE%backscatter_Ro_pow + Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag_bc / FatH)**MEKE%backscatter_Ro_pow RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & From 571013dad0a7f4971f629cbda16b1c396620d812 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 12 Jan 2021 15:32:40 -0500 Subject: [PATCH 119/212] +Added MOM_coms_wrapper.F90 Added the new module MOM_coms_wrapper, along with explicit interfaces for the broadcast routine for the cases that might actually be used by MOM6. With these new interfaces, the source PE has been made into an optional argument, and there is a new optional argument to indicate whether the broadcast is blocking. Also the MOM_horizontal_regridding module has been updated to reflect these changes. All answers are bitwise identical, but an existing required argument to broadcast has been made optional and there is a new optional argument. --- src/framework/MOM_coms.F90 | 19 +-- src/framework/MOM_coms_wrapper.F90 | 160 ++++++++++++++++++++ src/framework/MOM_horizontal_regridding.F90 | 52 +++---- 3 files changed, 183 insertions(+), 48 deletions(-) create mode 100644 src/framework/MOM_coms_wrapper.F90 diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 04ed46ad22..13fc4df75d 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -5,22 +5,19 @@ module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING -use fms_mod, only : fms_end, MOM_infra_init => fms_init -use memutils_mod, only : print_memuse_stats -use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes -use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist -use mpp_mod, only : broadcast => mpp_broadcast, field_chksum => mpp_chksum -use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min +use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs, Set_PElist, Get_PElist +use MOM_coms_wrapper, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end +use MOM_coms_wrapper, only : sum_across_PEs, max_across_PEs, min_across_PEs implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum +public :: Set_PElist, Get_PElist public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) public :: query_EFP_overflow_error, reset_EFP_overflow_error -public :: Set_PElist, Get_PElist ! This module provides interfaces to the non-domain-oriented communication subroutines. @@ -880,12 +877,4 @@ subroutine EFP_val_sum_across_PEs(EFP, error) end subroutine EFP_val_sum_across_PEs - -!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. -!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. -subroutine MOM_infra_end - call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) - call fms_end -end subroutine MOM_infra_end - end module MOM_coms diff --git a/src/framework/MOM_coms_wrapper.F90 b/src/framework/MOM_coms_wrapper.F90 new file mode 100644 index 0000000000..954f6da93c --- /dev/null +++ b/src/framework/MOM_coms_wrapper.F90 @@ -0,0 +1,160 @@ +!> Thin interfaces to non-domain-oriented mpp communication subroutines +module MOM_coms_wrapper + +! This file is part of MOM6. See LICENSE.md for the license. + +use fms_mod, only : fms_end, MOM_infra_init => fms_init +use memutils_mod, only : print_memuse_stats +use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes +use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, field_chksum => mpp_chksum +use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end, Set_PElist, Get_PElist +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum + +! This module provides interfaces to the non-domain-oriented communication subroutines. + +!> Communicate an array, string or scalar from one PE to others +interface broadcast + module procedure broadcast_char, broadcast_int0D, broadcast_int1D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D +end interface broadcast + +contains + +!> Communicate a 1-D array of character strings from one PE to others +subroutine broadcast_char(dat, length, from_PE, PElist, blocking) + character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination + integer, intent(in) :: length !< The length of each string + 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_char + +!> Communicate an integer from one PE to others +subroutine broadcast_int0D(dat, from_PE, PElist, blocking) + integer, intent(inout) :: dat !< The data to communicate and destination + 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, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int0D + +!> Communicate a 1-D array of integers from one PE to others +subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) + integer, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The 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_int1D + +!> Communicate a real number from one PE to others +subroutine broadcast_real0D(dat, from_PE, PElist, blocking) + real, intent(inout) :: dat !< The data to communicate and destination + 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, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real0D + +!> Communicate a 1-D array of reals from one PE to others +subroutine broadcast_real1D(dat, length, from_PE, PElist, blocking) + real, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The 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_real1D + +!> Communicate a 2-D array of reals from one PE to others +subroutine broadcast_real2D(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_real2D + + +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. +subroutine MOM_infra_end + call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) + call fms_end() +end subroutine MOM_infra_end + +end module MOM_coms_wrapper diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 4f98038f12..9b340f3aa7 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -3,32 +3,22 @@ module MOM_horizontal_regridding ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum -use MOM_coms, only : max_across_PEs, min_across_PEs -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, pass_vector, sum_across_PEs, broadcast -use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID +use MOM_debugging, only : hchksum +use MOM_coms, only : max_across_PEs, min_across_PEs, sum_across_PEs, broadcast +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 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 -use MOM_file_parser, only : log_version -use MOM_get_input, only : directories -use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_io, only : close_file, fieldtype, file_exists -use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE, MULTIPLE -use MOM_io, only : slasher, vardesc, write_field -use MOM_string_functions, only : uppercase -use MOM_time_manager, only : time_type, get_external_field_size -use MOM_time_manager, only : init_external_field -use MOM_time_manager, only : get_external_field_axes, get_external_field_missing +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io_wrapper, only : axistype, get_axis_data +use MOM_time_manager, only : time_type +use MOM_time_manager, only : init_external_field, get_external_field_size +use MOM_time_manager, only : get_external_field_axes, get_external_field_missing use MOM_transform_FMS, only : time_interp_external => rotated_time_interp_external -use MOM_variables, only : thermo_var_ptrs -use mpp_io_mod, only : axistype, mpp_get_axis_data -use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_max -use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_type -use horiz_interp_mod, only : horiz_interp_init, horiz_interp_del +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_type +use horiz_interp_mod, only : horiz_interp_init, horiz_interp_del use netcdf @@ -463,7 +453,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, endif max_depth = maxval(G%bathyT) - call mpp_max(max_depth) + call max_across_PEs(max_depth) if (z_edges_in(kd+1) Date: Wed, 13 Jan 2021 07:10:45 -0500 Subject: [PATCH 120/212] +Added MOM_interpolate.F90 Added the new module MOM_interpolate to wrap the time_interp_external and horiz_interp modules. The overloaded interface time_interp_external had to be renamed to time_interp_extern in the version offered by MOM_interpolate because of a weird compile time problem with the PGI 19.10.0 compiler. Some large blocks of unused code in MOM_horizontal_regridding were commented out. Also modified 6 files outside of the framework directory to use these new interfaces, but they will all work without these changes. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 49 ++-- config_src/coupled_driver/ocean_model_MOM.F90 | 22 +- config_src/solo_driver/MOM_driver.F90 | 14 +- src/core/MOM_open_boundary.F90 | 9 +- src/framework/MOM_horizontal_regridding.F90 | 234 +++++++++--------- src/framework/MOM_interpolate.F90 | 143 +++++++++++ src/ice_shelf/MOM_ice_shelf.F90 | 14 +- .../vertical/MOM_diabatic_aux.F90 | 8 +- 8 files changed, 313 insertions(+), 180 deletions(-) create mode 100644 src/framework/MOM_interpolate.F90 diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index be960accd6..67f6643a42 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -5,7 +5,7 @@ module MOM_surface_forcing_gfdl !#CTRL# use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts !#CTRL# use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end !#CTRL# use MOM_controlled_forcing, only : ctrl_forcing_CS -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT @@ -21,6 +21,8 @@ module MOM_surface_forcing_gfdl use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : init_external_field, time_interp_extern +use MOM_interpolate, only : time_interp_external_init use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state @@ -36,9 +38,6 @@ module MOM_surface_forcing_gfdl use coupler_types_mod, only : coupler_type_copy_data use data_override_mod, only : data_override_init, data_override use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init implicit none ; private @@ -350,7 +349,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) + call time_interp_extern(CS%id_srestore, Time, data_restore) ! 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 @@ -407,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) + call time_interp_extern(CS%id_trestore, Time, data_restore) 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) @@ -1486,7 +1485,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) enddo ; enddo endif - call time_interp_external_init + call time_interp_external_init() ! Optionally read a x-y gustiness field in place of a global constant. call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & @@ -1632,27 +1631,27 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) outunit = stdout() write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) + write(outunit,100) 'iobt%u_flux ', field_chksum( iobt%u_flux ) + write(outunit,100) 'iobt%v_flux ', field_chksum( iobt%v_flux ) + write(outunit,100) 'iobt%t_flux ', field_chksum( iobt%t_flux ) + write(outunit,100) 'iobt%q_flux ', field_chksum( iobt%q_flux ) + write(outunit,100) 'iobt%salt_flux ', field_chksum( iobt%salt_flux ) + write(outunit,100) 'iobt%lw_flux ', field_chksum( iobt%lw_flux ) + write(outunit,100) 'iobt%sw_flux_vis_dir', field_chksum( iobt%sw_flux_vis_dir) + write(outunit,100) 'iobt%sw_flux_vis_dif', field_chksum( iobt%sw_flux_vis_dif) + write(outunit,100) 'iobt%sw_flux_nir_dir', field_chksum( iobt%sw_flux_nir_dir) + write(outunit,100) 'iobt%sw_flux_nir_dif', field_chksum( iobt%sw_flux_nir_dif) + write(outunit,100) 'iobt%lprec ', field_chksum( iobt%lprec ) + write(outunit,100) 'iobt%fprec ', field_chksum( iobt%fprec ) + write(outunit,100) 'iobt%runoff ', field_chksum( iobt%runoff ) + write(outunit,100) 'iobt%calving ', field_chksum( iobt%calving ) + write(outunit,100) 'iobt%p ', field_chksum( iobt%p ) if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) + write(outunit,100) 'iobt%ustar_berg ', field_chksum( iobt%ustar_berg ) if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) + write(outunit,100) 'iobt%area_berg ', field_chksum( iobt%area_berg ) if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) + write(outunit,100) 'iobt%mass_berg ', field_chksum( iobt%mass_berg ) 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index b429da649b..12f803a970 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -15,6 +15,7 @@ module ocean_model_mod 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_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_mediator_close_registration, diag_mediator_end @@ -22,6 +23,7 @@ module ocean_model_mod use MOM_domains, only : TO_ALL, Omit_Corners use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type use MOM_forcing_type, only : fluxes_accumulate, get_net_mass_forcing @@ -48,6 +50,8 @@ module ocean_model_mod use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -56,10 +60,6 @@ module ocean_model_mod use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -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: MOM_wave_interface_init_lite, Update_Surface_Waves #include @@ -1130,13 +1130,13 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) outunit = stdout() write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) + write(outunit,100) 'ocean%t_surf ', field_chksum(ocn%t_surf ) + write(outunit,100) 'ocean%s_surf ', field_chksum(ocn%s_surf ) + write(outunit,100) 'ocean%u_surf ', field_chksum(ocn%u_surf ) + write(outunit,100) 'ocean%v_surf ', field_chksum(ocn%v_surf ) + write(outunit,100) 'ocean%sea_lev ', field_chksum(ocn%sea_lev) + write(outunit,100) 'ocean%frazil ', field_chksum(ocn%frazil ) + write(outunit,100) 'ocean%melt_potential ', field_chksum(ocn%melt_potential) call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 9726aa1281..c9383a4287 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -32,6 +32,7 @@ program MOM_main 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_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -41,6 +42,7 @@ program MOM_main use MOM_forcing_type, only : mech_forcing_diags, MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type + use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE @@ -64,8 +66,6 @@ program MOM_main use MOM_get_input, only : get_MOM_input use ensemble_manager_mod, only : ensemble_manager_init, get_ensemble_size use ensemble_manager_mod, only : ensemble_pelist_setup - use mpp_mod, only : set_current_pelist => mpp_set_current_pelist - use time_interp_external_mod, only : time_interp_external_init use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS @@ -229,7 +229,7 @@ program MOM_main allocate(ocean_pelist(nPEs_per)) call ensemble_pelist_setup(.true., 0, nPEs_per, 0, 0, atm_pelist, ocean_pelist, & land_pelist, ice_pelist) - call set_current_pelist(ocean_pelist) + call Set_PElist(ocean_pelist) deallocate(ocean_pelist) endif @@ -286,17 +286,17 @@ program MOM_main if (sum(date_init) > 0) then - Start_time = set_date(date_init(1),date_init(2), date_init(3), & - date_init(4),date_init(5),date_init(6)) + Start_time = set_date(date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6)) else Start_time = real_to_time(0.0) endif - call time_interp_external_init + call time_interp_external_init() if (sum(date) >= 0) then ! In this case, the segment starts at a time fixed by ocean_solo.res - segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) + segment_start_time = set_date(date(1), date(2), date(3), date(4), date(5), date(6)) Time = segment_start_time else ! In this case, the segment starts at a time read from the MOM restart file diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3fc0c9bcba..4faab21177 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -24,8 +24,7 @@ module MOM_open_boundary 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 time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_extern, time_interp_external_init 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 @@ -3897,7 +3896,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after ! reading the value, it is currently not possible to use the rotated - ! implementation of time_interp_external. + ! implementation of time_interp_extern. ! For now, we must explicitly allocate and rotate this array. if (turns /= 0) then if (modulo(turns, 2) /= 0) then @@ -3909,7 +3908,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tmp_buffer_in => tmp_buffer endif - call time_interp_external(segment%field(m)%fid,Time, tmp_buffer_in) + call time_interp_extern(segment%field(m)%fid,Time, tmp_buffer_in) ! NOTE: Rotation of face-points require that we skip the final value if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. @@ -3976,7 +3975,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! no dz for tidal variables if (segment%field(m)%nk_src > 1 .and.& (index(segment%field(m)%name, 'phase') .le. 0 .and. index(segment%field(m)%name, 'amp') .le. 0)) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) + call time_interp_extern(segment%field(m)%fid_dz,Time, tmp_buffer_in) if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. if (segment%is_E_or_W & diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 9b340f3aa7..6e09d391d9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -13,12 +13,8 @@ module MOM_horizontal_regridding use MOM_grid, only : ocean_grid_type use MOM_io_wrapper, only : axistype, get_axis_data use MOM_time_manager, only : time_type -use MOM_time_manager, only : init_external_field, get_external_field_size -use MOM_time_manager, only : get_external_field_axes, get_external_field_missing -use MOM_transform_FMS, only : time_interp_external => rotated_time_interp_external - -use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_type -use horiz_interp_mod, only : horiz_interp_init, horiz_interp_del +use MOM_interpolate, only : time_interp_extern, get_external_field_info, horiz_interp_init +use MOM_interpolate, only : horiz_interp_new, horiz_interp, horiz_interp_type use netcdf @@ -31,10 +27,10 @@ module MOM_horizontal_regridding ! character(len=40) :: mdl = "MOM_horizontal_regridding" ! This module's name. !> Fill grid edges -interface fill_boundaries - module procedure fill_boundaries_real - module procedure fill_boundaries_int -end interface +! interface fill_boundaries +! module procedure fill_boundaries_real +! module procedure fill_boundaries_int +! end interface !> Extrapolate and interpolate data interface horiz_interp_and_extrap_tracer @@ -296,7 +292,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real :: PI_180 integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp - integer :: i,j,k + integer :: i, j, k integer, dimension(4) :: start, count, dims, dim_id real, dimension(:,:), allocatable :: x_in, y_in real, dimension(:), allocatable :: lon_in, lat_in @@ -309,7 +305,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, character(len=8) :: laynum type(horiz_interp_type) :: Interp integer :: is, ie, js, je ! compute domain indices - integer :: isc,iec,jsc,jec ! global compute domain indices + integer :: isc, iec, jsc, jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read @@ -318,9 +314,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real :: npoints,varAvg real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out real, dimension(SZI_(G),SZJ_(G)) :: good, fill - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev - real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 - real, dimension(SZI_(G),SZJ_(G)) :: nlevs + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf, tr_prev + real, dimension(SZI_(G),SZJ_(G)) :: good2, fill2 + real, dimension(SZI_(G),SZJ_(G)) :: nlevs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -328,14 +324,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) - is_ongrid=.false. - if (present(ongrid)) is_ongrid=ongrid + is_ongrid = .false. + if (present(ongrid)) is_ongrid = ongrid if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) if (allocated(z_edges_in)) deallocate(z_edges_in) - PI_180=atan(1.0)/45. + PI_180 = atan(1.0)/45. ! Open NetCDF file and if present, extract data and spatial coordinate information ! The convention adopted here requires that the data be written in (i,j,k) ordering. @@ -391,7 +387,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) - allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1)) + allocate(lon_in(id), lat_in(jd), z_in(kd), z_edges_in(kd+1)) allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) start = 1 ; count = 1 ; count(1) = id @@ -692,7 +688,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_begin(id_clock_read) - fld_sz = get_external_field_size(fms_id) + call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_value) if (allocated(lon_in)) deallocate(lon_in) if (allocated(lat_in)) deallocate(lat_in) if (allocated(z_in)) deallocate(z_in) @@ -700,8 +696,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) - axes_data = get_external_field_axes(fms_id) - id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) spongeDataOngrid=.false. @@ -722,8 +716,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_end(id_clock_read) - missing_value = get_external_field_missing(fms_id) - if (.not. spongeDataOngrid) then ! extrapolate the input data to the north pole using the northerm-most latitude max_lat = maxval(lat_in) @@ -773,7 +765,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (.not.spongeDataOngrid) then if (is_root_pe()) & - call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) + call time_interp_extern(fms_id, Time, data_in, verbose=.true., 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 @@ -891,7 +883,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) + call time_interp_extern(fms_id, Time, data_in, verbose=.true., turns=turns) do k=1,kd do j=js,je do i=is,ie @@ -927,55 +919,55 @@ end subroutine meshgrid ! None of the subsequent code appears to be used at all. -!> Fill grid edges for integer data -function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) - integer, dimension(:,:), intent(in) :: m !< input array (ND) - logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant - logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold - integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp +! !> Fill grid edges for integer data +! function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) +! integer, dimension(:,:), intent(in) :: m !< input array (ND) +! logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant +! logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold +! integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp - real, dimension(size(m,1),size(m,2)) :: m_real - real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real +! real, dimension(size(m,1),size(m,2)) :: m_real +! real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real - m_real = real(m) +! m_real = real(m) - mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) +! mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) - mp = int(mp_real) +! mp = int(mp_real) -end function fill_boundaries_int +! end function fill_boundaries_int !> Fill grid edges for real data -function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) - real, dimension(:,:), intent(in) :: m !< input array (ND) - logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant - logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold - real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp +! function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) +! real, dimension(:,:), intent(in) :: m !< input array (ND) +! logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant +! logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold +! real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp - integer :: ni,nj,i,j +! integer :: ni,nj,i,j - ni=size(m,1); nj=size(m,2) +! ni=size(m,1); nj=size(m,2) - mp(1:ni,1:nj)=m(:,:) +! mp(1:ni,1:nj)=m(:,:) - if (cyclic_x) then - mp(0,1:nj)=m(ni,1:nj) - mp(ni+1,1:nj)=m(1,1:nj) - else - mp(0,1:nj)=m(1,1:nj) - mp(ni+1,1:nj)=m(ni,1:nj) - endif +! if (cyclic_x) then +! mp(0,1:nj)=m(ni,1:nj) +! mp(ni+1,1:nj)=m(1,1:nj) +! else +! mp(0,1:nj)=m(1,1:nj) +! mp(ni+1,1:nj)=m(ni,1:nj) +! endif - mp(1:ni,0)=m(1:ni,1) - if (tripolar_n) then - do i=1,ni - mp(i,nj+1)=m(ni-i+1,nj) - enddo - else - mp(1:ni,nj+1)=m(1:ni,nj) - endif +! mp(1:ni,0)=m(1:ni,1) +! if (tripolar_n) then +! do i=1,ni +! mp(i,nj+1)=m(ni-i+1,nj) +! enddo +! else +! mp(1:ni,nj+1)=m(1:ni,nj) +! endif -end function fill_boundaries_real +! end function fill_boundaries_real !> Solve del2 (zi) = 0 using successive iterations !! with a 5 point stencil. Only points fill==1 are @@ -983,64 +975,64 @@ end function fill_boundaries_real !! isotropically in index space. The resulting solution !! in each region is an approximation to del2(zi)=0 subject to !! boundary conditions along the valid points curve bounding this region. -subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) - real, dimension(:,:), intent(inout) :: zi !< input and output array (ND) - integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< same shape as zi, 1=fill - integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< same shape as zi, 1=bad data - real, intent(in) :: sor !< relaxation coefficient (ND) - integer, intent(in) :: niter !< maximum number of iterations - logical, intent(in) :: cyclic_x !< true if domain is zonally reentrant - logical, intent(in) :: tripolar_n !< true if domain has an Arctic fold - - ! Local variables - real, dimension(size(zi,1),size(zi,2)) :: res, m - integer, dimension(size(zi,1),size(zi,2),4) :: B - real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp - integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm - integer :: i,j,k,n - integer :: ni,nj - real :: Isum, bsum - - ni=size(zi,1) ; nj=size(zi,2) - - - mp(:,:) = fill_boundaries(zi,cyclic_x,tripolar_n) - - B(:,:,:) = 0.0 - nm(:,:) = fill_boundaries(bad,cyclic_x,tripolar_n) - - do j=1,nj - do i=1,ni - if (fill(i,j) == 1) then - B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) - B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) - endif - enddo - enddo - - do n=1,niter - do j=1,nj - do i=1,ni - if (fill(i,j) == 1) then - bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) - Isum = 1.0/bsum - res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& - B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) - endif - enddo - enddo - res(:,:)=res(:,:)*sor - - do j=1,nj - do i=1,ni - mp(i,j)=mp(i,j)+res(i,j) - enddo - enddo - - zi(:,:)=mp(1:ni,1:nj) - mp = fill_boundaries(zi,cyclic_x,tripolar_n) - enddo - -end subroutine smooth_heights +! subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) +! real, dimension(:,:), intent(inout) :: zi !< input and output array (ND) +! integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< same shape as zi, 1=fill +! integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< same shape as zi, 1=bad data +! real, intent(in) :: sor !< relaxation coefficient (ND) +! integer, intent(in) :: niter !< maximum number of iterations +! logical, intent(in) :: cyclic_x !< true if domain is zonally reentrant +! logical, intent(in) :: tripolar_n !< true if domain has an Arctic fold + +! ! Local variables +! real, dimension(size(zi,1),size(zi,2)) :: res, m +! integer, dimension(size(zi,1),size(zi,2),4) :: B +! real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp +! integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm +! integer :: i,j,k,n +! integer :: ni,nj +! real :: Isum, bsum + +! ni=size(zi,1) ; nj=size(zi,2) + + +! mp(:,:) = fill_boundaries(zi,cyclic_x,tripolar_n) + +! B(:,:,:) = 0.0 +! nm(:,:) = fill_boundaries(bad,cyclic_x,tripolar_n) + +! do j=1,nj +! do i=1,ni +! if (fill(i,j) == 1) then +! B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) +! B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) +! endif +! enddo +! enddo + +! do n=1,niter +! do j=1,nj +! do i=1,ni +! if (fill(i,j) == 1) then +! bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) +! Isum = 1.0/bsum +! res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& +! B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) +! endif +! enddo +! enddo +! res(:,:)=res(:,:)*sor + +! do j=1,nj +! do i=1,ni +! mp(i,j)=mp(i,j)+res(i,j) +! enddo +! enddo + +! zi(:,:)=mp(1:ni,1:nj) +! mp = fill_boundaries(zi,cyclic_x,tripolar_n) +! enddo + +! end subroutine smooth_heights end module MOM_horizontal_regridding diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 new file mode 100644 index 0000000000..c63c847e55 --- /dev/null +++ b/src/framework/MOM_interpolate.F90 @@ -0,0 +1,143 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interpolate + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : allocate_rotated_array, rotate_array +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io_wrapper, only : axistype +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_fms=>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_manager_mod, only : time_type + +implicit none ; private + +public :: time_interp_extern, init_external_field, time_interp_external_init +public :: get_external_field_info +public :: horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new + +!> Read a field based on model time, and rotate to the model domain. +! This inerface does not share the name time_interp_external with the module it primarily +! wraps because of errors (perhaps a bug) that arise with the PGI 19.10.0 compiler. +interface time_interp_extern + module procedure time_interp_external_0d + module procedure time_interp_external_2d + module procedure time_interp_external_3d +end interface time_interp_extern + +contains + +!> 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 + + if (present(size)) then + size(1:4) = get_external_field_size(field_id) + endif + + if (present(axes)) then + axes(1:4) = get_external_field_axes(field_id) + endif + + if (present(missing)) then + missing = get_external_field_missing(field_id) + endif + +end subroutine get_external_field_info + + +!> Read a scalar field based on model time. +subroutine time_interp_external_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() + 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_fms(field_id, time, data_in, verbose=verbose) +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, verbose, horz_interp, mask_out, turns) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_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 + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + 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, allocatable :: data_pre_rot(:,:) ! The input data before rotation + integer :: qturns ! The number of quarter turns to rotate the data + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call time_interp_external_fms(field_id, 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_external_fms(field_id, 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) + endif +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, & + verbose, horz_interp, mask_out, turns) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_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 + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + 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, allocatable :: data_pre_rot(:,:,:) ! The input data before rotation + integer :: qturns ! The number of quarter turns to rotate the data + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call time_interp_external_fms(field_id, 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_external_fms(field_id, 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) + endif +end subroutine time_interp_external_3d + +end module MOM_interpolate diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a5dd92b640..634ff80325 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -57,8 +57,8 @@ module MOM_ice_shelf use MOM_coms, only : reproducing_sum use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_extern, time_interp_external_init + implicit none ; private #include @@ -1084,9 +1084,9 @@ 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_extern(CS%id_read_mass, Time0, last_mass_shelf) do j=js,je ; do i=is,ie - ! This should only be done if time_interp_external did an update. + ! 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 last_h_shelf(i,j) = last_mass_shelf(i,j) / CS%density_ice enddo ; enddo @@ -1512,7 +1512,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%rotate_index) then allocate(tmp2d(CS%Grid_in%isd:CS%Grid_in%ied,CS%Grid_in%jsd:CS%Grid_in%jed));tmp2d(:,:)=0.0 call MOM_read_data(TideAmp_file, 'tideamp', tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) - call rotate_array(tmp2d,CS%turns, CS%utide) + 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) @@ -1984,8 +1984,8 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) allocate(tmp2d(is:ie,js:je)) ; tmp2d(:,:) = 0.0 endif - call time_interp_external(CS%id_read_mass, Time, tmp2d) - call rotate_array(tmp2d,CS%turns, ISS%mass_shelf) + call time_interp_extern(CS%id_read_mass, Time, tmp2d) + call rotate_array(tmp2d, CS%turns, ISS%mass_shelf) deallocate(tmp2d) ! This should only be done if time_interp_external did an update. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 470098a08a..8ba9dd959a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -15,15 +15,15 @@ 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_interpolate, only : init_external_field, time_interp_extern +use MOM_interpolate, only : time_interp_external_init 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 use MOM_tracer_flow_control, only : get_chl_from_model, tracer_flow_control_CS use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs ! , vertvisc_type, accel_diag_ptrs +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init implicit none ; private @@ -621,7 +621,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity_CSp, tracer_ 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_extern(CS%sbc_chl, CS%Time, chl_2d) do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& From 77d0cbe9cb948bbe9a7630e26803521ed090d19c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Jan 2021 15:06:48 -0500 Subject: [PATCH 121/212] Corrected a bug using IO_LAYOUT in place of LAYOUT Corrected a bug that was incorrectly using the IO_LAYOUT to set LAYOUT when the IO_LAYOUT uses non-default values greater than 1. All answers are bitwise identical in any cases that worked. --- src/framework/MOM_domains.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 65e7337964..56ac0b3ccf 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1571,7 +1571,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, lay if (io_layout(1) == 0) then MOM_dom%io_layout(1) = layout(1) elseif (io_layout(1) > 1) then - MOM_dom%layout(1) = io_layout(1) + MOM_dom%io_layout(1) = io_layout(1) if (modulo(layout(1), io_layout(1)) /= 0) then write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) @@ -1582,7 +1582,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, lay if (io_layout(2) == 0) then MOM_dom%io_layout(2) = layout(2) elseif (io_layout(2) > 1) then - MOM_dom%layout(2) = io_layout(2) + MOM_dom%io_layout(2) = io_layout(2) if (modulo(layout(2), io_layout(2)) /= 0) then write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) From a0eb0b69be2b58428b95c736d5655fcd10a65f46 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 13 Jan 2021 12:50:03 -0500 Subject: [PATCH 122/212] Always stream job logs in gitlab pipeline - When a batch job fails we used to see the job logs but we suspect this behavior changed a long time ago. This commit intercepts an error from the sbatch command and causes the pipeline to fail only after streaming the log. --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 40b2705995..1f9768a6a8 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -117,8 +117,9 @@ run: - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh + - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh || MJOB_RETURN_STATE=Fail - cat log.$CI_PIPELINE_ID + - test -z "$MJOB_RETURN_STATE" - test -f restart_results_gnu.tar.gz - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz From 43ae9ae7d6340db6a2500acdaf0d7410de2c3462 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 13 Jan 2021 18:29:16 -0500 Subject: [PATCH 123/212] Adds --with-driver option to configure - Following suggestion from @marshallward I've implemented an option to select the driver code at the configure stage (changes to configure.ac) - This allows the target build/coupled/ocean_model_MOM.o to be built using the .testing ac tools. --- .testing/Makefile | 23 ++++++----------------- ac/configure.ac | 10 ++++++++-- 2 files changed, 14 insertions(+), 19 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index a780f19323..2806d54130 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -226,7 +226,9 @@ build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLA 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/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) +build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) +build/mct/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) # Configure script flags build/symmetric/Makefile: MOM_ACFLAGS= @@ -234,7 +236,9 @@ build/asymmetric/Makefile: MOM_ACFLAGS=--enable-asymmetric build/repro/Makefile: MOM_ACFLAGS= build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp build/target/Makefile: MOM_ACFLAGS= - +build/coupled/Makefile: MOM_ACFLAGS=--with-driver=coupled_driver +build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_driver +build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_driver # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) @@ -336,29 +340,14 @@ $(DEPS)/Makefile: ../ac/deps/Makefile # - use autoconf rather than mkmf templates MK_TEMPLATE ?= ../../$(DEPS)/mkmf/templates/ncrc-gnu.mk # NUOPC driver -build/nuopc/Makefile: ../config_src/nuopc_driver $(MOM_SOURCE) - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/nuopc_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names build/nuopc/mom_ocean_model_nuopc.o: build/nuopc/Makefile cd $(@D) && make $(@F) check_mom6_api_nuopc: build/nuopc/mom_ocean_model_nuopc.o # GFDL coupled driver -build/coupled/Makefile: ../config_src/coupled_driver $(MOM_SOURCE) - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/coupled_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names 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/Makefile: ../config_src/mct_driver $(MOM_SOURCE) - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/list_paths -l ../../$(DEPS)/fms/src ../../../config_src/mct_driver ../../../config_src/dynamic_symmetric ../../../src/ ../../../config_src/external \ - && $(MOM_ENV) ../../$(DEPS)/mkmf/bin/mkmf -t $(MK_TEMPLATE) -p MOM6 path_names 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 diff --git a/ac/configure.ac b/ac/configure.ac index ad8ed83603..487230beb8 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -48,6 +48,12 @@ AC_ARG_ENABLE([asymmetric], AS_IF([test "$enable_asymmetric" = yes], [MEM_LAYOUT=${srcdir}/config_src/dynamic]) +# Default to solo_driver +DRIVER_DIR=${srcdir}/config_src/solo_driver +AC_ARG_WITH([driver], + AS_HELP_STRING([--with-driver=coupled_driver|solo_driver], [Select directory for driver source code])) +AS_IF([test "x$with_driver" != "x"], + [DRIVER_DIR=${srcdir}/config_src/${with_driver}]) # TODO: Rather than point to a pre-configured header file, autoconf could be # used to configure a header based on a template. @@ -210,10 +216,10 @@ AS_IF([test -z "$MKMF"], [ AC_CONFIG_COMMANDS([path_names], [list_paths -l \ ${srcdir}/src \ - ${srcdir}/config_src/solo_driver \ ${srcdir}/config_src/ext* \ + ${DRIVER_DIR} \ ${MEM_LAYOUT} -], [MEM_LAYOUT=$MEM_LAYOUT]) +], [MEM_LAYOUT=$MEM_LAYOUT DRIVER_DIR=$DRIVER_DIR]) AC_CONFIG_COMMANDS([Makefile.mkmf], From 76cb4718d01dab9ab0c714cba310f13675c5f5dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Jan 2021 16:03:32 -0500 Subject: [PATCH 124/212] Cleaned up MOM_horizontal_regridding Partially cleaned up MOM_horizontal_regridding.F90, including the elimination of several unused routines, the addition of comments describing variables, and some white space corrections. All answers are bitwise identical. --- src/framework/MOM_horizontal_regridding.F90 | 335 +++++++------------- 1 file changed, 110 insertions(+), 225 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 537c7e4d92..f1ab073938 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -11,10 +11,10 @@ module MOM_horizontal_regridding use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io_wrapper, only : axistype, get_axis_data -use MOM_time_manager, only : time_type use MOM_interpolate, only : time_interp_extern, get_external_field_info, horiz_interp_init use MOM_interpolate, only : horiz_interp_new, horiz_interp, horiz_interp_type +use MOM_io_wrapper, only : axistype, get_axis_data +use MOM_time_manager, only : time_type use netcdf @@ -24,14 +24,6 @@ module MOM_horizontal_regridding public :: horiz_interp_and_extrap_tracer, myStats -! character(len=40) :: mdl = "MOM_horizontal_regridding" ! This module's name. - -!> Fill grid edges -! interface fill_boundaries -! module procedure fill_boundaries_real -! module procedure fill_boundaries_int -! end interface - !> Extrapolate and interpolate data interface horiz_interp_and_extrap_tracer module procedure horiz_interp_and_extrap_tracer_record @@ -80,10 +72,9 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) end subroutine myStats -!> Use ICE-9 algorithm to populate points (fill=1) with -!! valid data (good=1). If no information is available, -!! Then use a previous guess (prev). Optionally (smooth) -!! blend the filled points to achieve a more desirable result. +!> Use ICE-9 algorithm to populate points (fill=1) with valid data (good=1). If no information +!! is available, use a previous guess (prev). Optionally (smooth) blend the filled points to +!! achieve a more desirable result. subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, debug, answers_2018) use MOM_coms, only : sum_across_PEs @@ -108,15 +99,20 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. - real, dimension(SZI_(G),SZJ_(G)) :: b,r - real, dimension(SZI_(G),SZJ_(G)) :: fill_pts, good_, good_new - + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled + real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration + real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration + + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values + real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values + real :: ngood ! The number of valid values in neighboring points + logical :: do_smooth ! Indicates whether to do smoothing of the array + real :: nfill ! The remaining number of points to fill + real :: nfill_prev ! The previous value of nfill character(len=256) :: mesg ! The text of an error message - integer :: i,j,k - real :: east,west,north,south,sor - real :: ge,gw,gn,gs,ngood - logical :: do_smooth,siena_bug - real :: nfill, nfill_prev + integer :: i, j, k integer, parameter :: num_pass_default = 10000 real, parameter :: relc_default = 0.25, crit_default = 1.e-3 @@ -151,15 +147,15 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, nfill_prev = nfill good_(:,:) = good(:,:) - r(:,:) = 0.0 + a_chg(:,:) = 0.0 do while (nfill > 0.0) call pass_var(good_,G%Domain) call pass_var(aout,G%Domain) - b(:,:)=aout(:,:) - good_new(:,:)=good_(:,:) + a_filled(:,:) = aout(:,:) + good_new(:,:) = good_(:,:) do j=js,je ; do i=is,ie @@ -180,16 +176,16 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, endif if (ngood > 0.) then if (ans_2018) then - b(i,j)=(east+west+north+south)/ngood + a_filled(i,j) = (east+west+north+south)/ngood else - b(i,j) = ((east+west) + (north+south))/ngood + a_filled(i,j) = ((east+west) + (north+south))/ngood endif fill_pts(i,j) = 0.0 good_new(i,j) = 1.0 endif enddo ; enddo - aout(is:ie,js:je) = b(is:ie,js:je) + aout(is:ie,js:je) = a_filled(is:ie,js:je) good_(is:ie,js:je) = good_new(is:ie,js:je) nfill_prev = nfill nfill = sum(fill_pts(is:ie,js:je)) @@ -209,11 +205,13 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, call MOM_error(WARNING, mesg, .true.) endif + ! Determine the number of remaining points to fill globally. nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - enddo + enddo ! while block for remaining points to fill. + ! Do Laplacian smoothing for the points that have been filled in. if (do_smooth) then ; do k=1,npass call pass_var(aout,G%Domain) do j=js,je ; do i=is,ie @@ -221,22 +219,22 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, 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 - r(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)) + 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 - r(i,j) = relax_coeff*( ((south*aout(i,j-1) + north*aout(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) ) endif else - r(i,j) = 0. + a_chg(i,j) = 0. endif enddo ; enddo ares = 0.0 do j=js,je ; do i=is,ie - aout(i,j) = r(i,j) + aout(i,j) - ares = max(ares, abs(r(i,j))) + aout(i,j) = a_chg(i,j) + aout(i,j) + ares = max(ares, abs(a_chg(i,j))) enddo ; enddo call max_across_PEs(ares) if (ares <= acrit) exit @@ -285,9 +283,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, !! extrapolation is performed by this routine ! Local variables - real, dimension(:,:), allocatable :: tr_in, tr_inp ! A 2-d array for holding input data on - ! native horizontal grid and extended grid - ! with poles. + real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its + !! native horizontal grid. + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid. real :: PI_180 @@ -295,8 +293,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, integer :: i, j, k integer, dimension(4) :: start, count, dims, dim_id real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in - real, dimension(:), allocatable :: lat_inp, last_row + real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole real :: max_lat, min_lat, pole, max_depth, npole real :: roundoff ! The magnitude of roundoff, usually ~2e-16. real :: add_offset, scale_factor @@ -311,12 +309,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, integer :: id_clock_read character(len=12) :: dim_name(4) logical :: debug=.false. - real :: npoints,varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out - real, dimension(SZI_(G),SZJ_(G)) :: good, fill - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf, tr_prev - real, dimension(SZI_(G),SZJ_(G)) :: good2, fill2 - real, dimension(SZI_(G),SZJ_(G)) :: nlevs + real :: npoints, varAvg + real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid + real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -407,7 +408,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif - ! extrapolate the input data to the north pole using the northerm-most latitude + ! extrapolate the input data to the north pole using the northern-most latitude add_np = .false. jdp = jd if (.not. is_ongrid) then @@ -445,7 +446,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, allocate(tr_in(id,jd)) ; tr_in(:,:) = 0.0 allocate(tr_inp(id,jdp)) ; tr_inp(:,:) = 0.0 allocate(mask_in(id,jdp)) ; mask_in(:,:) = 0.0 - allocate(last_row(id)) ; last_row(:) = 0.0 endif max_depth = maxval(G%bathyT) @@ -488,11 +488,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, trim(varnam)//" in file "// trim(filename)) if (add_np) then - last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 + pole = 0.0 ; npole = 0.0 do i=1,id if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 + pole = pole + tr_in(i,jd) + npole = npole + 1.0 endif enddo if (npole > 0) then @@ -525,12 +525,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (.not. is_ongrid) then if (k == 1) then - call horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & - interp_method='bilinear',src_modulo=.true.) + call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) endif if (debug) then - call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') + call myStats(tr_inp,missing_value, is, ie, js, je, k,'Tracer from file') endif endif @@ -538,7 +538,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_ongrid) then tr_out(is:ie,js:je)=tr_in(is:ie,js:je) else - call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) endif mask_out=1.0 @@ -591,7 +591,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, fill2(:,:) = fill(:,:) call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) - call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') + if (debug) then + call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') + endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) mask_z(:,:,k) = good2(:,:) + fill2(:,:) @@ -634,9 +636,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t !! add parentheses for rotational symmetry. ! Local variables - real, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on - !! native horizontal grid and extended grid - !! with poles. + real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its + !! native horizontal grid. + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. real, dimension(:,:,:), allocatable :: data_in !< A buffer for storing the full 3-d time-interpolated array !! on the original grid real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid. @@ -646,8 +648,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t integer :: i,j,k integer, dimension(4) :: start, count, dims, dim_id real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in - real, dimension(:), allocatable :: lat_inp, last_row + real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole real :: max_lat, min_lat, pole, max_depth, npole real :: roundoff ! The magnitude of roundoff, usually ~2e-16. logical :: add_np @@ -663,12 +665,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t character(len=12) :: dim_name(4) logical :: debug=.false. logical :: spongeDataOngrid - real :: npoints,varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out - real, dimension(SZI_(G),SZJ_(G)) :: good, fill - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev - real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 - real, dimension(SZI_(G),SZJ_(G)) :: nlevs + real :: npoints, varAvg + real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid + real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 integer :: turns turns = G%HI%turns @@ -679,7 +684,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) - PI_180=atan(1.0)/45. + PI_180 = atan(1.0)/45. ! Open NetCDF file and if present, extract data and spatial coordinate information ! The convention adopted here requires that the data be written in (i,j,k) ordering. @@ -696,15 +701,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) - spongeDataOngrid=.false. - if (PRESENT(spongeOngrid)) spongeDataOngrid=spongeOngrid + spongeDataOngrid = .false. + if (PRESENT(spongeOngrid)) spongeDataOngrid = spongeOngrid if (.not. spongeDataOngrid) then - allocate(lon_in(id),lat_in(jd)) + 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) endif - allocate(z_in(kd),z_edges_in(kd+1)) + allocate(z_in(kd), z_edges_in(kd+1)) allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) @@ -715,9 +720,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_end(id_clock_read) if (.not. spongeDataOngrid) then - ! extrapolate the input data to the north pole using the northerm-most latitude + ! Extrapolate the input data to the north pole using the northerm-most latitude. max_lat = maxval(lat_in) - add_np=.false. + add_np = .false. if (max_lat < 90.0) then add_np = .true. jdp = jd+1 @@ -728,7 +733,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t allocate(lat_in(1:jdp)) lat_in(:) = lat_inp(:) else - jdp=jd + jdp = jd endif call horiz_interp_init() lon_in = lon_in*PI_180 @@ -741,7 +746,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 - allocate(last_row(id)) ; last_row(:)=0.0 else allocate(data_in(isd:ied,jsd:jed,kd)) endif @@ -764,40 +768,39 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (.not.spongeDataOngrid) then if (is_root_pe()) & call time_interp_extern(fms_id, Time, data_in, verbose=.true., 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 + ! 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 - last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 - do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 - endif - enddo - if (npole > 0) then - pole=pole/npole - else - pole=missing_value - endif - tr_inp(:,1:jd) = tr_in(:,:) - tr_inp(:,jdp) = pole + pole = 0.0 ; npole = 0.0 + do i=1,id + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + pole = pole + tr_in(i,jd) + npole = npole+1.0 + endif + enddo + if (npole > 0) then + pole = pole / npole + else + pole = missing_value + endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole else - tr_inp(:,:) = tr_in(:,:) + tr_inp(:,:) = tr_in(:,:) endif endif call broadcast(tr_inp, id*jdp, blocking=.true.) - mask_in=0.0 + mask_in(:,:) = 0.0 do j=1,jdp ; do i=1,id if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j)=1.0 + mask_in(i,j) = 1.0 tr_inp(i,j) = tr_inp(i,j) * conversion else tr_inp(i,j) = missing_value @@ -837,7 +840,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j)) .and. & (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 + fill(i,j) = 1.0 enddo ; enddo call pass_var(fill, G%Domain) call pass_var(good, G%Domain) @@ -881,15 +884,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_extern(fms_id, Time, data_in, verbose=.true., turns=turns) - do k=1,kd - do j=js,je - do i=is,ie - tr_z(i,j,k)=data_in(i,j,k) - if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. - enddo + call time_interp_extern(fms_id, Time, data_in, verbose=.true., turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k) = data_in(i,j,k) + if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. enddo enddo + enddo endif end subroutine horiz_interp_and_extrap_tracer_fms_id @@ -901,9 +904,9 @@ subroutine meshgrid(x, y, x_T, y_T) 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 - integer :: ni,nj,i,j + integer :: ni, nj, i, j - ni=size(x,1) ; nj=size(y,1) + ni = size(x,1) ; nj = size(y,1) do j=1,nj ; do i=1,ni x_T(i,j) = x(i) @@ -915,122 +918,4 @@ subroutine meshgrid(x, y, x_T, y_T) end subroutine meshgrid -! None of the subsequent code appears to be used at all. - -! !> Fill grid edges for integer data -! function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) -! integer, dimension(:,:), intent(in) :: m !< input array (ND) -! logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant -! logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold -! integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp - -! real, dimension(size(m,1),size(m,2)) :: m_real -! real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real - -! m_real = real(m) - -! mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) - -! mp = int(mp_real) - -! end function fill_boundaries_int - -!> Fill grid edges for real data -! function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) -! real, dimension(:,:), intent(in) :: m !< input array (ND) -! logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant -! logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold -! real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp - -! integer :: ni,nj,i,j - -! ni=size(m,1); nj=size(m,2) - -! mp(1:ni,1:nj)=m(:,:) - -! if (cyclic_x) then -! mp(0,1:nj)=m(ni,1:nj) -! mp(ni+1,1:nj)=m(1,1:nj) -! else -! mp(0,1:nj)=m(1,1:nj) -! mp(ni+1,1:nj)=m(ni,1:nj) -! endif - -! mp(1:ni,0)=m(1:ni,1) -! if (tripolar_n) then -! do i=1,ni -! mp(i,nj+1)=m(ni-i+1,nj) -! enddo -! else -! mp(1:ni,nj+1)=m(1:ni,nj) -! endif - -! end function fill_boundaries_real - -!> Solve del2 (zi) = 0 using successive iterations -!! with a 5 point stencil. Only points fill==1 are -!! modified. Except where bad==1, information propagates -!! isotropically in index space. The resulting solution -!! in each region is an approximation to del2(zi)=0 subject to -!! boundary conditions along the valid points curve bounding this region. -! subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) -! real, dimension(:,:), intent(inout) :: zi !< input and output array (ND) -! integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< same shape as zi, 1=fill -! integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< same shape as zi, 1=bad data -! real, intent(in) :: sor !< relaxation coefficient (ND) -! integer, intent(in) :: niter !< maximum number of iterations -! logical, intent(in) :: cyclic_x !< true if domain is zonally reentrant -! logical, intent(in) :: tripolar_n !< true if domain has an Arctic fold - -! ! Local variables -! real, dimension(size(zi,1),size(zi,2)) :: res, m -! integer, dimension(size(zi,1),size(zi,2),4) :: B -! real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp -! integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm -! integer :: i,j,k,n -! integer :: ni,nj -! real :: Isum, bsum - -! ni=size(zi,1) ; nj=size(zi,2) - - -! mp(:,:) = fill_boundaries(zi,cyclic_x,tripolar_n) - -! B(:,:,:) = 0.0 -! nm(:,:) = fill_boundaries(bad,cyclic_x,tripolar_n) - -! do j=1,nj -! do i=1,ni -! if (fill(i,j) == 1) then -! B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) -! B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) -! endif -! enddo -! enddo - -! do n=1,niter -! do j=1,nj -! do i=1,ni -! if (fill(i,j) == 1) then -! bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) -! Isum = 1.0/bsum -! res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& -! B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) -! endif -! enddo -! enddo -! res(:,:)=res(:,:)*sor - -! do j=1,nj -! do i=1,ni -! mp(i,j)=mp(i,j)+res(i,j) -! enddo -! enddo - -! zi(:,:)=mp(1:ni,1:nj) -! mp = fill_boundaries(zi,cyclic_x,tripolar_n) -! enddo - -! end subroutine smooth_heights - end module MOM_horizontal_regridding From e4d984a7ad66527c3508e28c8f64798b76740044 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 12:47:53 -0500 Subject: [PATCH 125/212] +Created MOM_diag_manager to wrap diag_manager Moved MOM_diag_manager_wrapper.F90 to MOM_diag_manager.F90 (mostly for brevity) and added use statements and provided interfaces for all of the diag_manager_mod, diag_data_mod and diag_axis_mod routines that are used within the MOM6 code, with some renaming of interfaces to reflect their use within the MOM6 code. All answers are bitwise identical. --- src/diagnostics/MOM_obsolete_diagnostics.F90 | 4 +- ...nager_wrapper.F90 => MOM_diag_manager.F90} | 19 +++++++--- src/framework/MOM_diag_mediator.F90 | 38 +++++++------------ src/framework/MOM_diag_remap.F90 | 4 +- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 18 ++++----- 5 files changed, 39 insertions(+), 44 deletions(-) rename src/framework/{MOM_diag_manager_wrapper.F90 => MOM_diag_manager.F90} (88%) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index e30749984d..bba8379bbb 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -4,10 +4,10 @@ module MOM_obsolete_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_diag_manager, only : register_static_field_fms +use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : param_file_type, log_version, get_param -use MOM_diag_mediator, only : diag_ctrl -use diag_manager_mod, only : register_static_field_fms=>register_static_field implicit none ; private diff --git a/src/framework/MOM_diag_manager_wrapper.F90 b/src/framework/MOM_diag_manager.F90 similarity index 88% rename from src/framework/MOM_diag_manager_wrapper.F90 rename to src/framework/MOM_diag_manager.F90 index 47dc701798..0c9f875bcd 100644 --- a/src/framework/MOM_diag_manager_wrapper.F90 +++ b/src/framework/MOM_diag_manager.F90 @@ -1,14 +1,23 @@ -!> A simple (very thin) wrapper for register_diag_field to avoid a compiler bug with PGI -module MOM_diag_manager_wrapper +!> A simple (very thin) wrapper for the FMS diag_manager routines, with some name changes +module MOM_diag_manager ! This file is part of MOM6. See LICENSE.md for the license. use MOM_time_manager, only : time_type +use diag_axis_mod, only : diag_axis_init, get_diag_axis_name, EAST, NORTH +use diag_data_mod, only : null_axis_id +use diag_manager_mod, only : diag_manager_init, diag_manager_end +use diag_manager_mod, only : send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND use diag_manager_mod, only : 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 implicit none ; private -public register_diag_field_fms +public diag_manager_init, diag_manager_end +public diag_axis_init, get_diag_axis_name, EAST, NORTH, null_axis_id +public send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND +public register_diag_field_fms, register_static_field_fms, get_diag_field_id_fms !> A wrapper for register_diag_field_array() interface register_diag_field_fms @@ -85,11 +94,11 @@ integer function register_diag_field_scalar_fms(module_name, field_name, init_ti end function register_diag_field_scalar_fms -!> \namespace mom_diag_manager_wrapper +!> \namespace mom_diag_manager !! !! This module simply wraps register_diag_field() from FMS's diag_manager_mod. !! We used to be able to import register_diag_field and rename it to register_diag_field_fms !! with a simple "use, only : register_diag_field_fms => register_diag_field" but PGI 16.5 !! has a bug that refuses to compile this - earlier versions did work. -end module MOM_diag_manager_wrapper +end module MOM_diag_manager diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index fa4a4a2701..071585a951 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -9,37 +9,28 @@ module MOM_diag_mediator use MOM_coms, only : PE_here 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_manager, only : diag_manager_init, diag_manager_end +use MOM_diag_manager, only : diag_axis_init, get_diag_axis_name, null_axis_id +use MOM_diag_manager, only : send_data, diag_field_add_attribute, EAST, NORTH +use MOM_diag_manager, only : register_diag_field_fms, register_static_field_fms +use MOM_diag_manager, only : get_diag_field_id_fms, DIAG_FIELD_NOT_FOUND +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 +use MOM_diag_remap, only : horizontally_average_diag_field, diag_remap_get_axes_info +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_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, query_vardesc, mom_read_data +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_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : EOS_type -use MOM_diag_remap, only : diag_remap_ctrl -use MOM_diag_remap, only : diag_remap_update -use MOM_diag_remap, only : 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 -use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured -use MOM_diag_remap, only : diag_remap_get_axes_info, diag_remap_set_active -use MOM_diag_remap, only : diag_remap_diag_registration_closed -use MOM_diag_remap, only : horizontally_average_diag_field - -use diag_axis_mod, only : get_diag_axis_name -use diag_data_mod, only : null_axis_id -use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_axis_init, EAST, NORTH, diag_field_add_attribute -! The following module is needed for PGI since the following line does not compile with PGI 6.5.0 -! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field -use MOM_diag_manager_wrapper, only : register_diag_field_fms -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 diag_manager_mod, only : DIAG_FIELD_NOT_FOUND implicit none ; private @@ -482,10 +473,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - ! Axis group for special null axis from diag manager + ! Axis group for special null axis from diag manager. (Could null_axis_id be made MOM specific?) call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) - !Non-native Non-downsampled if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index f27a153a2b..462ba7bf5e 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -60,6 +60,8 @@ module MOM_diag_remap use MOM_coms, only : reproducing_sum_EFP, EFP_to_real use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING +use MOM_debugging, only : check_column_integrals +use MOM_diag_manager, only : 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_io, only : slasher, mom_read_data @@ -80,9 +82,7 @@ module MOM_diag_remap use coord_sigma, only : build_sigma_column use coord_rho, only : build_rho_column -use diag_manager_mod, only : diag_axis_init -use MOM_debugging, only : check_column_integrals implicit none ; private public diag_remap_ctrl diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 90ae47450d..397696c0ba 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -3,19 +3,15 @@ module MOM_IS_diag_mediator ! This file is a part of SIS2. See LICENSE.md for the license. -use MOM_grid, only : ocean_grid_type - -use MOM_coms, only : PE_here +use MOM_coms, only : PE_here +use MOM_diag_manager, only : diag_manager_init, send_data, diag_axis_init, EAST, NORTH +use MOM_diag_manager, only : register_diag_field_fms, register_static_field_fms use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_string_functions, only : lowercase, uppercase, slasher -use MOM_time_manager, only : time_type - -use diag_manager_mod, only : diag_manager_init -use diag_manager_mod, only : send_data, diag_axis_init,EAST,NORTH -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 MOM_time_manager, only : time_type implicit none ; private From 76b3ccce48a1d4fb1c61fe6aee0a06d5b60a6219 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 13:57:13 -0500 Subject: [PATCH 126/212] Use only for netcdf in MOM_horizontal_regridding Made netcdf module use dependencies explicit in MOM_horizontal_regridding.F90. All answers are bitwise identical. --- src/framework/MOM_horizontal_regridding.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index f1ab073938..b91509cc1d 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_io_wrapper, only : axistype, get_axis_data use MOM_time_manager, only : time_type -use netcdf +use netcdf, only : NF90_OPEN, NF90_NOWRITE, NF90_GET_ATT, NF90_GET_VAR +use netcdf, only : NF90_INQ_VARID, NF90_INQUIRE_VARIABLE, NF90_INQUIRE_DIMENSION implicit none ; private From 1c88a3956c54e73fb2302a8a49d4f5c0abfd6952 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 20:57:20 -0500 Subject: [PATCH 127/212] +Rearranged MOM_domains modules Moved MOM_domains.F90 to MOM_domain_infra.F90 and MOM_domain_init.F90 to MOM_domains.F90, and eliminated MOM_domains_init from MOM_domain_infra.F90. The interfaces from MOM_domains.F90 that were previously used are still available from the new MOM_domains module. Also replaced the tripolar argument to create_MOM_domain with the simple logical tripolar_N. All answers are bitwise identical, but a module name that was briefly in use no longer exists. --- src/core/MOM.F90 | 2 +- src/framework/MOM_domain_infra.F90 | 1795 +++++++++++++++++++++++++ src/framework/MOM_domain_init.F90 | 330 ----- src/framework/MOM_domains.F90 | 1992 ++-------------------------- src/framework/MOM_io.F90 | 4 +- src/framework/MOM_io_wrapper.F90 | 4 +- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- 7 files changed, 1912 insertions(+), 2219 deletions(-) create mode 100644 src/framework/MOM_domain_infra.F90 delete mode 100644 src/framework/MOM_domain_init.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ce0343f714..193ab63f02 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -23,7 +23,7 @@ module MOM use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage -use MOM_domain_init, only : MOM_domains_init +use MOM_domains, only : MOM_domains_init use MOM_domains, only : sum_across_PEs, pass_var, pass_vector, clone_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 new file mode 100644 index 0000000000..e97ca4e18a --- /dev/null +++ b/src/framework/MOM_domain_infra.F90 @@ -0,0 +1,1795 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array +use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe + +use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary +use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain +use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains +use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain, mpp_get_domain_components +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_update_domains, global_field_sum => mpp_global_sum +use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains +use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type +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 : compute_block_extent => mpp_compute_block_extent +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 : 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_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get + +implicit none ; private + +public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain +public :: create_MOM_domain, clone_MOM_domain, get_domain_components +public :: deallocate_MOM_domain, deallocate_domain_contents +public :: get_domain_extent, get_domain_extent_dsamp2 +public :: pass_var, pass_vector, fill_symmetric_edges, global_field_sum +public :: pass_var_start, pass_var_complete +public :: pass_vector_start, pass_vector_complete +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +public :: create_group_pass, do_group_pass, group_pass_type +public :: start_group_pass, complete_group_pass +public :: compute_block_extent, get_global_shape, get_layout_extents +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: domain2D, domain1D + +!> Do a halo update on an array +interface pass_var + module procedure pass_var_3d, pass_var_2d +end interface pass_var + +!> Do a halo update on a pair of arrays representing the two components of a vector +interface pass_vector + module procedure pass_vector_3d, pass_vector_2d +end interface pass_vector + +!> Initiate a non-blocking halo update on an array +interface pass_var_start + module procedure pass_var_start_3d, pass_var_start_2d +end interface pass_var_start + +!> Complete a non-blocking halo update on an array +interface pass_var_complete + module procedure pass_var_complete_3d, pass_var_complete_2d +end interface pass_var_complete + +!> Initiate a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_start + module procedure pass_vector_start_3d, pass_vector_start_2d +end interface pass_vector_start + +!> Complete a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_complete + module procedure pass_vector_complete_3d, pass_vector_complete_2d +end interface pass_vector_complete + +!> Set up a group of halo updates +interface create_group_pass + module procedure create_var_group_pass_2d + module procedure create_var_group_pass_3d + module procedure create_vector_group_pass_2d + module procedure create_vector_group_pass_3d +end interface create_group_pass + +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain +interface fill_symmetric_edges + module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d +! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d +end interface fill_symmetric_edges + +!> Copy one MOM_domain_type into another +interface clone_MOM_domain + module procedure clone_MD_to_MD, clone_MD_to_d2D +end interface clone_MOM_domain + +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> The MOM_domain_type contains information about the domain decomposition. +type, public :: MOM_domain_type + type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos + !! on this processor, centered at h points. + type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + !! on this processor, centered at h points. + integer :: niglobal !< The total horizontal i-domain size. + integer :: njglobal !< The total horizontal j-domain size. + integer :: nihalo !< The i-halo size in memory. + integer :: njhalo !< The j-halo size in memory. + logical :: symmetric !< True if symmetric memory is used with + !! this domain. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + logical :: thin_halo_updates !< If true, optional arguments may be used to + !! specify the width of the halos that are + !! updated with each call. + integer :: layout(2) !< This domain's processor layout. This is + !! saved to enable the construction of related + !! new domains with different resolutions or + !! other properties. + integer :: io_layout(2) !< The IO-layout used with this domain. + integer :: X_FLAGS !< Flag that specifies the properties of the + !! domain in the i-direction in a define_domain call. + integer :: Y_FLAGS !< Flag that specifies the properties of the + !! domain in the j-direction in a define_domain call. + logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating + !! which logical processors are actually used for + !! the ocean code. The other logical processors + !! would be contain only land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. +end type MOM_domain_type + +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions + +contains + +!> pass_var_3d does a halo update for a three-dimensional array. +subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_3d + +!> pass_var_2d does a halo update for a two-dimensional array. +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo + !! by default. + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_2d + +!> pass_var_start_2d starts a halo update for a two-dimensional array. +function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_2d + +!> pass_var_start_3d starts a halo update for a three-dimensional array. +function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_3d !< The integer index for this update. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_3d + +!> pass_var_complete_2d completes a halo update for a two-dimensional array. +subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_2d + +!> pass_var_complete_3d completes a halo update for a three-dimensional array. +subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_3d + +!> pass_vector_2d does a halo update for a pair of two-dimensional arrays +!! representing the compontents of a two-dimensional horizontal vector. +subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_2d + +!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only +!! fill in the values at the edge of a pair of symmetric memory two-dimensional +!! arrays representing the compontents of a two-dimensional horizontal vector. +!! If symmetric memory is not being used, this subroutine does nothing except to +!! possibly turn optional cpu clocks on or off. +subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: scalar !< An optional argument indicating whether. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y + logical :: block_til_complete + + if (.not. MOM_dom%symmetric) then + return + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return + + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + + ! Adjust isc, etc., to account for the fact that the input arrays indices all + ! start at 1 (and are effectively on a SW grid!). + isc = isc - (isd-1) ; iec = iec - (isd-1) + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) + IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 + + dirflag = To_All ! 60 + if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif + + if (stagger_local == CGRID_NE) then + allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) + wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbuffery=sbuff_y, & + gridtype=CGRID_NE) + do i=isc,iec + v_cmpt(i,JscB) = sbuff_y(i) + enddo + do j=jsc,jec + u_cmpt(IscB,j) = wbuff_x(j) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_y) + elseif (stagger_local == BGRID_NE) then + allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) + allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) + wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbufferx=sbuff_x, & + wbuffery=wbuff_y, sbuffery=sbuff_y, & + gridtype=BGRID_NE) + do I=IscB,IecB + u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) + enddo + do J=JscB,JecB + u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_x) + deallocate(wbuff_y) ; deallocate(sbuff_y) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine fill_vector_symmetric_edges_2d + +!> pass_vector_3d does a halo update for a pair of three-dimensional arrays +!! representing the compontents of a three-dimensional horizontal vector. +subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_3d + +!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays +!! representing the compontents of a two-dimensional horizontal vector. +function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_2d !< The integer index for this + !! update. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_2d + +!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays +!! representing the compontents of a three-dimensional horizontal vector. +function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_3d !< The integer index for this + !! update. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_3d + +!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays +!! representing the compontents of a two-dimensional horizontal vector. +subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_2d + +!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional +!! arrays representing the compontents of a three-dimensional horizontal vector. +subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_3d + +!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. +subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & + halo, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_2d + +!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. +subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_3d + +!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. +subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_2d + +!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. +subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_3d + +!> do_group_pass carries out a group halo update. +subroutine do_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine do_group_pass + +!> start_group_pass starts out a group halo update. +subroutine start_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine start_group_pass + +!> complete_group_pass completes a group halo update. +subroutine complete_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine complete_group_pass + +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds + integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. + integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. + integer :: xhalo_d2, yhalo_d2 + character(len=200) :: mesg ! A string for use in error messages + character(len=64) :: dom_name ! The domain name + logical :: mask_table_exists ! Mask_table is present and the file it points to exists + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + + dom_name = "MOM" ; if (present(domain_name)) dom_name = trim(domain_name) + + X_FLAGS = 0 ; Y_FLAGS = 0 + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar_N) then + Y_FLAGS = FOLD_NORTH_EDGE + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") + endif + + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%io_layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%io_layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + global_indices(1:4) = (/ 1, MOM_dom%niglobal, 1, MOM_dom%njglobal /) + + if (present(mask_table)) then + mask_table_exists = file_exist(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) + endif + else + mask_table_exists = .false. + endif + + if (mask_table_exists) then + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & + symmetry = MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap ) + else + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & + symmetry = MOM_dom%symmetric, name=dom_name) + endif + + if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) + endif + + !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. + !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get + !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 + xhalo_d2 = int(MOM_dom%nihalo/2) + yhalo_d2 = int(MOM_dom%njhalo/2) + global_indices(1:4) = (/ 1, int(MOM_dom%niglobal/2), 1, int(MOM_dom%njglobal/2) /) + if (mask_table_exists) then + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc"), & + maskmap=MOM_dom%maskmap ) + else + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc")) + endif + + if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. & + (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain_d2, MOM_dom%io_layout) + endif + +end subroutine create_MOM_domain + +!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type +!! and all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + + if (associated(MOM_domain)) then + call deallocate_domain_contents(MOM_domain, cursory) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> deallocate_domain_contents deallocates memory associated with pointers +!! inside of a MOM_domain_type. +subroutine deallocate_domain_contents(MOM_domain, cursory) + type(MOM_domain_type), intent(inout) :: MOM_domain !< A MOM_domain_type whose contents will be deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + + logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain%mpp_domain)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) + deallocate(MOM_domain%mpp_domain) + endif + if (associated(MOM_domain%mpp_domain_d2)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) + deallocate(MOM_domain%mpp_domain_d2) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + +end subroutine deallocate_domain_contents + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sest the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) +end subroutine set_MOM_thread_affinity + +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +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) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns + + integer :: global_indices(4) + logical :: mask_table_exists + character(len=64) :: dom_name + integer :: qturns + + qturns = 0 + if (present(turns)) qturns = turns + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + +! Save the extra data for creating other domains of different resolution that overlay this domain + MOM_dom%symmetric = MD_in%symmetric + MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + + 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) + 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 + + 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(:) + endif + + global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal + global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal + + if (associated(MD_in%maskmap)) then + mask_table_exists = .true. + allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) + if (qturns /= 0) then + call rotate_array(MD_in%maskmap(:,:), qturns, MOM_dom%maskmap(:,:)) + else + MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) + endif + else + mask_table_exists = .false. + endif + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + endif + + if (present(halo_size)) then + MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size + endif + + if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + + dom_name = "MOM" + if (present(domain_name)) dom_name = trim(domain_name) + + if (mask_table_exists) then + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) + else + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & + symmetry=MOM_dom%symmetric, name=dom_name) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name) + endif + + if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & + (MOM_dom%layout(1)*MOM_dom%layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) + endif + +end subroutine clone_MD_to_MD + +!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new +!! domain2d type, while allowing some properties of the new type to differ from +!! the original one. +subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & + domain_name, turns) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< If true, swap X and Y axes + + integer :: global_indices(4), layout(2), io_layout(2) + integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo + logical :: symmetric_dom + character(len=64) :: dom_name + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + +! Save the extra data for creating other domains of different resolution that overlay this domain + niglobal = MD_in%niglobal ; njglobal = MD_in%njglobal + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + + symmetric_dom = MD_in%symmetric + + X_FLAGS = MD_in%X_FLAGS ; Y_FLAGS = MD_in%Y_FLAGS + layout(:) = MD_in%layout(:) ; io_layout(:) = MD_in%io_layout(:) + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + nihalo = max(nihalo, min_halo(1)) + njhalo = max(njhalo, min_halo(2)) + min_halo(1) = nihalo ; min_halo(2) = njhalo + endif + + if (present(halo_size)) then + nihalo = halo_size ; njhalo = halo_size + endif + + if (present(symmetric)) then ; symmetric_dom = symmetric ; endif + + dom_name = "MOM" + if (present(domain_name)) dom_name = trim(domain_name) + + global_indices(1) = 1 ; global_indices(2) = niglobal + global_indices(3) = 1 ; global_indices(4) = njglobal + if (associated(MD_in%maskmap)) then + call MOM_define_domain( global_indices, layout, mpp_domain, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=nihalo, yhalo=njhalo, & + symmetry = symmetric, name=dom_name, & + maskmap=MD_in%maskmap ) + else + call MOM_define_domain( global_indices, layout, mpp_domain, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=nihalo, yhalo=njhalo, & + symmetry = symmetric, name=dom_name) + endif + + if ((io_layout(1) + io_layout(2) > 0) .and. & + (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(mpp_domain, io_layout) + endif + +end subroutine clone_MD_to_d2D + +!> Returns various data that has been stored in a MOM_domain_type +subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, intent(out) :: isg !< The start i-index of the global domain + integer, intent(out) :: ieg !< The end i-index of the global domain + integer, intent(out) :: jsg !< The start j-index of the global domain + integer, intent(out) :: jeg !< The end j-index of the global domain + integer, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. + integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This + !! can be useful for some types of debugging with + !! dynamic memory allocation. + ! Local variables + integer :: ind_off + logical :: local + + local = .true. ; if (present(local_indexing)) local = local_indexing + ind_off = 0 ; if (present(index_offset)) ind_off = index_offset + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain, isg, ieg, jsg, jeg) + + ! This code institutes the MOM convention that local array indices start at 1. + if (local) then + idg_offset = isd-1 ; jdg_offset = jsd-1 + isc = isc-isd+1 ; iec = iec-isd+1 ; jsc = jsc-jsd+1 ; jec = jec-jsd+1 + ied = ied-isd+1 ; jed = jed-jsd+1 + isd = 1 ; jsd = 1 + else + idg_offset = 0 ; jdg_offset = 0 + endif + if (ind_off /= 0) then + idg_offset = idg_offset + ind_off ; jdg_offset = jdg_offset + ind_off + isc = isc + ind_off ; iec = iec + ind_off + jsc = jsc + ind_off ; jec = jec + ind_off + isd = isd + ind_off ; ied = ied + ind_off + jsd = jsd + ind_off ; jed = jed + ind_off + endif + symmetric = Domain%symmetric + +end subroutine get_domain_extent + +subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& + isd_d2, ied_d2, jsd_d2, jed_d2,& + isg_d2, ieg_d2, jsg_d2, jeg_d2) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc_d2 !< The start i-index of the computational domain + integer, intent(out) :: iec_d2 !< The end i-index of the computational domain + integer, intent(out) :: jsc_d2 !< The start j-index of the computational domain + integer, intent(out) :: jec_d2 !< The end j-index of the computational domain + integer, intent(out) :: isd_d2 !< The start i-index of the data domain + integer, intent(out) :: ied_d2 !< The end i-index of the data domain + integer, intent(out) :: jsd_d2 !< The start j-index of the data domain + integer, intent(out) :: jed_d2 !< The end j-index of the data domain + integer, intent(out) :: isg_d2 !< The start i-index of the global domain + integer, intent(out) :: ieg_d2 !< The end i-index of the global domain + integer, intent(out) :: jsg_d2 !< The start j-index of the global domain + integer, intent(out) :: jeg_d2 !< The end j-index of the global domain + + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) + call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) + ! This code institutes the MOM convention that local array indices start at 1. + isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 + jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 + ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 + isd_d2 = 1 ; jsd_d2 = 1 +end subroutine get_domain_extent_dsamp2 + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + +!> Returns the global shape of h-point arrays +subroutine get_global_shape(domain, niglobal, njglobal) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(out) :: niglobal !< i-index global size of h-point arrays + integer, intent(out) :: njglobal !< j-index global size of h-point arrays + + niglobal = domain%niglobal + njglobal = domain%njglobal +end subroutine get_global_shape + +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + +end module MOM_domain_infra diff --git a/src/framework/MOM_domain_init.F90 b/src/framework/MOM_domain_init.F90 deleted file mode 100644 index 25064cf24e..0000000000 --- a/src/framework/MOM_domain_init.F90 +++ /dev/null @@ -1,330 +0,0 @@ -!> Describes the decomposed MOM domain and has routines for communications across PEs -module MOM_domain_init - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coms, only : num_PEs -use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_define_layout -use MOM_domains, only : MOM_thread_affinity_set, set_MOM_thread_affinity -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io, only : file_exists -use MOM_string_functions, only : slasher - -implicit none ; private - -public :: MOM_domains_init, MOM_domain_type - -contains - -!> 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, & - 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(param_file_type), intent(in) :: param_file !< A structure to parse for - !! run-time parameters - logical, optional, intent(in) :: symmetric !< If present, this specifies - !! whether this domain is symmetric, regardless of - !! whether the macro SYMMETRIC_MEMORY_ is defined. - logical, optional, intent(in) :: static_memory !< If present and true, this - !! domain type is set up for static memory and - !! error checking of various input values is - !! performed against those in the input file. - integer, optional, intent(in) :: NIHALO !< Default halo sizes, required - !! with static memory. - integer, optional, intent(in) :: NJHALO !< Default halo sizes, required - !! with static memory. - integer, optional, intent(in) :: NIGLOBAL !< Total domain sizes, required - !! with static memory. - integer, optional, intent(in) :: NJGLOBAL !< Total domain sizes, required - !! with static memory. - integer, optional, intent(in) :: NIPROC !< Processor counts, required with - !! static memory. - integer, optional, intent(in) :: NJPROC !< Processor counts, required with - !! static memory. - integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the i- and j- - !! directions, and returns the actual halo size used. - character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" - !! if missing. - character(len=*), optional, intent(in) :: include_name !< A name for model's include file, - !! "MOM_memory.h" if missing. - character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to - !! layout-specific parameters. - - ! Local variables - integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions - 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 - integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain - integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos - integer :: nihalo_dflt, njhalo_dflt ! The default halo sizes - integer :: PEs_used ! The number of processors used - logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. - logical, dimension(2,2) :: tripolar ! A set of flag indicating whether there is tripolar - ! connectivity for any of the four logical edges of the grid. - ! Currently only tripolar_N is implemented. - logical :: is_static ! If true, static memory is being used for this domain. - logical :: is_symmetric ! True if the domain being set up will use symmetric 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 :: 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 - character(len=64) :: inc_nm ! The name of the memory include file - character(len=200) :: mesg ! A string to use for error messages - - integer :: nip_parsed, njp_parsed - 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 - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl ! This module's name. - - PEs_used = num_PEs() - - mdl = "MOM_domains" !### Change this to "MOM_domain_init" - - is_symmetric = .true. ; if (present(symmetric)) is_symmetric = symmetric - if (present(min_halo)) mdl = trim(mdl)//" min_halo" - - inc_nm = "MOM_memory.h" ; if (present(include_name)) inc_nm = trim(include_name) - - nihalo_nm = "NIHALO" ; njhalo_nm = "NJHALO" - layout_nm = "LAYOUT" ; io_layout_nm = "IO_LAYOUT" ; masktable_nm = "MASKTABLE" - niproc_nm = "NIPROC" ; njproc_nm = "NJPROC" - if (present(param_suffix)) then ; if (len(trim(adjustl(param_suffix))) > 0) then - nihalo_nm = "NIHALO"//(trim(adjustl(param_suffix))) - njhalo_nm = "NJHALO"//(trim(adjustl(param_suffix))) - layout_nm = "LAYOUT"//(trim(adjustl(param_suffix))) - io_layout_nm = "IO_LAYOUT"//(trim(adjustl(param_suffix))) - masktable_nm = "MASKTABLE"//(trim(adjustl(param_suffix))) - niproc_nm = "NIPROC"//(trim(adjustl(param_suffix))) - njproc_nm = "NJPROC"//(trim(adjustl(param_suffix))) - endif ; endif - - is_static = .false. ; if (present(static_memory)) is_static = static_memory - if (is_static) then - if (.not.present(NIHALO)) call MOM_error(FATAL, "NIHALO must be "// & - "present in the call to MOM_domains_init with static memory.") - if (.not.present(NJHALO)) call MOM_error(FATAL, "NJHALO must be "// & - "present in the call to MOM_domains_init with static memory.") - if (.not.present(NIGLOBAL)) call MOM_error(FATAL, "NIGLOBAL must be "// & - "present in the call to MOM_domains_init with static memory.") - if (.not.present(NJGLOBAL)) call MOM_error(FATAL, "NJGLOBAL must be "// & - "present in the call to MOM_domains_init with static memory.") - if (.not.present(NIPROC)) call MOM_error(FATAL, "NIPROC must be "// & - "present in the call to MOM_domains_init with static memory.") - if (.not.present(NJPROC)) call MOM_error(FATAL, "NJPROC must be "// & - "present in the call to MOM_domains_init with static memory.") - endif - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) - call get_param(param_file, mdl, "REENTRANT_X", reentrant(1), & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "REENTRANT_Y", reentrant(2), & - "If true, the domain is meridionally reentrant.", & - default=.false.) - tripolar(1:2,1:2) = .false. - call get_param(param_file, mdl, "TRIPOLAR_N", tripolar(2,2), & - "Use tripolar connectivity at the northern edge of the "//& - "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & - default=.false.) - -# ifndef NOT_SET_AFFINITY - !$ 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.) - !$ 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) - !$ endif -# endif - - call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", is_symmetric, & - "If defined, the velocity point data domain includes every face of the "//& - "thickness points. In other words, some arrays are larger than others, "//& - "depending on where they are on the staggered grid. Also, the starting "//& - "index of the velocity-point arrays is usually 0, not 1. "//& - "This can only be set at compile time.",& - layoutParam=.true.) - call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & - "If true, non-blocking halo updates may be used.", & - default=.false., layoutParam=.true.) - !### Note the duplicated "the the" in the following description, which should be fixed as a part - ! of a larger commit that also changes other MOM_parameter_doc file messages, but for now - ! reproduces the existing output files. - call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & - "If true, optional arguments may be used to specify the the width of the "//& - "halos that are updated with each call.", & - default=.true., layoutParam=.true.) - - nihalo_dflt = 4 ; njhalo_dflt = 4 - if (present(NIHALO)) nihalo_dflt = NIHALO - if (present(NJHALO)) njhalo_dflt = NJHALO - - call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & - "If STATIC_MEMORY_ is defined, the principle variables will have sizes that "//& - "are statically determined at compile time. Otherwise the sizes are not "//& - "determined until run time. The STATIC option is substantially faster, but "//& - "does not allow the PE count to be changed at run time. This can only be "//& - "set at compile time.", layoutParam=.true.) - - if (is_static) then - call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & - "The total number of thickness grid points in the x-direction in the physical "//& - "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NIGLOBAL) - call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & - "The total number of thickness grid points in the y-direction in the physical "//& - "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NJGLOBAL) - if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") - if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") - - ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. - if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then - write( char_xsiz, '(i4)' ) NIPROC - write( char_ysiz, '(i4)' ) NJPROC - write( char_niglobal, '(i4)' ) NIGLOBAL - write( char_njglobal, '(i4)' ) NJGLOBAL - call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& - trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& - 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') - call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in '//trim(inc_nm)//' to use '//& - 'dynamic allocation, or change processor decomposition to evenly divide the domain.') - endif - else - call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & - "The total number of thickness grid points in the x-direction in the physical "//& - "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & - "The total number of thickness grid points in the y-direction in the physical "//& - "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - fail_if_missing=.true.) - endif - - call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & - "The number of halo points on each side in the x-direction. How this is set "//& - "varies with the calling component and static or dynamic memory configuration.", & - default=nihalo_dflt, static_value=nihalo_dflt) - call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & - "The number of halo points on each side in the y-direction. How this is set "//& - "varies with the calling component and static or dynamic memory configuration.", & - default=njhalo_dflt, static_value=njhalo_dflt) - if (present(min_halo)) then - n_halo(1) = max(n_halo(1), min_halo(1)) - min_halo(1) = n_halo(1) - n_halo(2) = max(n_halo(2), min_halo(2)) - min_halo(2) = n_halo(2) - ! These are generally used only with static memory, so they are considerd layout params. - call log_param(param_file, mdl, "!NIHALO min_halo", n_halo(1), layoutParam=.true.) - call log_param(param_file, mdl, "!NJHALO min_halo", n_halo(2), layoutParam=.true.) - endif - if (is_static .and. .not.present(min_halo)) then - if (n_halo(1) /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(nihalo_nm)//" domain size") - if (n_halo(2) /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(njhalo_nm)//" domain size") - endif - - 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) - - if (is_static) then - layout(1) = NIPROC ; layout(2) = NJPROC - else - call get_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout to be used, or 0, 0 to automatically set the layout "//& - "based on the number of processors.", default=0, do_not_log=.true.) - call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & - "The number of processors in the x-direction.", default=-1, do_not_log=.true.) - call get_param(param_file, mdl, trim(njproc_nm), njp_parsed, & - "The number of processors in the y-direction.", default=-1, do_not_log=.true.) - if (nip_parsed > -1) then - if ((layout(1) > 0) .and. (layout(1) /= nip_parsed)) & - call MOM_error(FATAL, trim(layout_nm)//" and "//trim(niproc_nm)//" set inconsistently. "//& - "Only LAYOUT should be used.") - layout(1) = nip_parsed - call MOM_mesg(trim(niproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& - "Shift to using "//trim(layout_nm)//" instead.") - endif - if (njp_parsed > -1) then - if ((layout(2) > 0) .and. (layout(2) /= njp_parsed)) & - call MOM_error(FATAL, trim(layout_nm)//" and "//trim(njproc_nm)//" set inconsistently. "//& - "Only "//trim(layout_nm)//" should be used.") - layout(2) = njp_parsed - call MOM_mesg(trim(njproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& - "Shift to using "//trim(layout_nm)//" instead.") - endif - - if ( (layout(1) == 0) .and. (layout(2) == 0) ) & - call MOM_define_layout( (/ 1, n_global(1), 1, n_global(2) /), PEs_used, layout) - if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) - if ( (layout(1) == 0) .and. (layout(2) /= 0) ) layout(1) = PEs_used / layout(2) - - if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then - write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & - & 2i4,", is not the number of PEs used, ",i5,".")') & - layout(1), layout(2), PEs_used - call MOM_error(FATAL, mesg) - endif - endif - call log_param(param_file, mdl, trim(niproc_nm), layout(1), & - "The number of processors in the x-direction. With STATIC_MEMORY_ this "//& - "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) - call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the y-direction. With STATIC_MEMORY_ this "//& - "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) - call log_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout that was actually used.", layoutParam=.true.) - - ! Idiot check that fewer PEs than columns have been requested - if (layout(1)*layout(2) > n_global(1)*n_global(2)) then - write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & - 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' - call MOM_error(FATAL, mesg) - endif - - if (mask_table_exists) & - call MOM_error(NOTE, 'MOM_domains_init: reading maskmap information from '//trim(mask_table)) - - ! 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.) - - call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, & - io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & - symmetric=symmetric, thin_halos=thin_halos, nonblocking=nonblocking) - -end subroutine MOM_domains_init - -end module MOM_domain_init diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 56ac0b3ccf..f4f3d307ac 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,40 +3,35 @@ module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_array_transform, only : rotate_array -use MOM_coms, only : PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end -use MOM_coms, only : broadcast, sum_across_PEs, min_across_PEs, max_across_PEs -use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end -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 -use MOM_file_parser, only : param_file_type +use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs, broadcast +use MOM_coms_wrapper, only : sum_across_PEs, min_across_PEs, max_across_PEs +use MOM_coms_wrapper, only : MOM_infra_init, MOM_infra_end +use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, create_MOM_domain +use MOM_domain_infra, only : get_domain_extent, get_domain_extent_dsamp2 +use MOM_domain_infra, only : clone_MOM_domain, get_domain_components +use MOM_domain_infra, only : deallocate_MOM_domain, deallocate_domain_contents +use MOM_domain_infra, only : MOM_define_domain, MOM_define_layout, MOM_define_io_domain +use MOM_domain_infra, only : pass_var, pass_vector +use MOM_domain_infra, only : pass_var_start, pass_var_complete, fill_symmetric_edges +use MOM_domain_infra, only : pass_vector_start, pass_vector_complete +use MOM_domain_infra, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domain_infra, only : start_group_pass, complete_group_pass +use MOM_domain_infra, only : global_field_sum +use MOM_domain_infra, only : compute_block_extent, get_global_shape, get_layout_extents +use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +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_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io_wrapper, only : file_exists use MOM_string_functions, only : slasher -use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary -use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain -use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains -use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain, mpp_get_domain_components -use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain -use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain -use mpp_domains_mod, only : global_field_sum => mpp_global_sum -use mpp_domains_mod, only : mpp_update_domains, CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE -use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains -use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update -use mpp_domains_mod, only : group_pass_type => mpp_group_update_type -use mpp_domains_mod, only : mpp_reset_group_update_field -use mpp_domains_mod, only : mpp_group_update_initialized -use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update -use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent -use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -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_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get - implicit none ; private -public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 +public :: MOM_domains_init, MOM_domain_type, MOM_infra_init, MOM_infra_end +public :: domain2D, domain1D +public :: get_domain_extent, get_domain_extent_dsamp2 public :: create_MOM_domain, clone_MOM_domain, get_domain_components public :: deallocate_MOM_domain, deallocate_domain_contents public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain @@ -44,1140 +39,15 @@ module MOM_domains public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -public :: CORNER, CENTER, NORTH_FACE, EAST_FACE -public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape, get_layout_extents -public :: MOM_thread_affinity_set, set_MOM_thread_affinity -public :: get_simple_array_i_ind, get_simple_array_j_ind -public :: domain2D, domain1D - -!> Do a halo update on an array -interface pass_var - module procedure pass_var_3d, pass_var_2d -end interface pass_var - -!> Do a halo update on a pair of arrays representing the two components of a vector -interface pass_vector - module procedure pass_vector_3d, pass_vector_2d -end interface pass_vector - -!> Initiate a non-blocking halo update on an array -interface pass_var_start - module procedure pass_var_start_3d, pass_var_start_2d -end interface pass_var_start - -!> Complete a non-blocking halo update on an array -interface pass_var_complete - module procedure pass_var_complete_3d, pass_var_complete_2d -end interface pass_var_complete - -!> Initiate a halo update on a pair of arrays representing the two components of a vector -interface pass_vector_start - module procedure pass_vector_start_3d, pass_vector_start_2d -end interface pass_vector_start - -!> Complete a halo update on a pair of arrays representing the two components of a vector -interface pass_vector_complete - module procedure pass_vector_complete_3d, pass_vector_complete_2d -end interface pass_vector_complete - -!> Set up a group of halo updates -interface create_group_pass - module procedure create_var_group_pass_2d - module procedure create_var_group_pass_3d - module procedure create_vector_group_pass_2d - module procedure create_vector_group_pass_3d -end interface create_group_pass - -!> Do a set of halo updates that fill in the values at the duplicated edges -!! of a staggered symmetric memory domain -interface fill_symmetric_edges - module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d -! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d -end interface fill_symmetric_edges - -!> Copy one MOM_domain_type into another -interface clone_MOM_domain - module procedure clone_MD_to_MD, clone_MD_to_d2D -end interface clone_MOM_domain - -!> Extract the 1-d domain components from a MOM_domain or domain2d -interface get_domain_components - module procedure get_domain_components_MD, get_domain_components_d2D -end interface get_domain_components - -!> The MOM_domain_type contains information about the domain decomposition. -type, public :: MOM_domain_type - type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos - !! on this processor, centered at h points. - type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos - !! on this processor, centered at h points. - integer :: niglobal !< The total horizontal i-domain size. - integer :: njglobal !< The total horizontal j-domain size. - integer :: nihalo !< The i-halo size in memory. - integer :: njhalo !< The j-halo size in memory. - logical :: symmetric !< True if symmetric memory is used with - !! this domain. - logical :: nonblocking_updates !< If true, non-blocking halo updates are - !! allowed. The default is .false. (for now). - logical :: thin_halo_updates !< If true, optional arguments may be used to - !! specify the width of the halos that are - !! updated with each call. - integer :: layout(2) !< This domain's processor layout. This is - !! saved to enable the construction of related - !! new domains with different resolutions or - !! other properties. - integer :: io_layout(2) !< The IO-layout used with this domain. - integer :: X_FLAGS !< Flag that specifies the properties of the - !! domain in the i-direction in a define_domain call. - integer :: Y_FLAGS !< Flag that specifies the properties of the - !! domain in the j-direction in a define_domain call. - logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating - !! which logical processors are actually used for - !! the ocean code. The other logical processors - !! would be contain only land points and are not - !! assigned to actual processors. This need not be - !! assigned if all logical processors are used. -end type MOM_domain_type - -integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners contains -!> pass_var_3d does a halo update for a three-dimensional array. -subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & - clock) - real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before - !! progress resumes. Omitting complete is the - !! same as setting complete to .true. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - integer :: dirflag - logical :: block_til_complete - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - block_til_complete = .true. - if (present(complete)) block_til_complete = complete - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & - complete=block_til_complete, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & - complete=block_til_complete, position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_var_3d - -!> pass_var_2d does a halo update for a two-dimensional array. -subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) - real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before - !! progress resumes. Omitting complete is the - !! same as setting complete to .true. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo - !! by default. - integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, - !! or 0 to avoid updating symmetric memory - !! computational domain points. Setting this >=0 - !! also enforces that complete=.true. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - ! Local variables - real, allocatable, dimension(:,:) :: tmp - integer :: pos, i_halo, j_halo - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB - integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn - integer :: dirflag - logical :: block_til_complete - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - block_til_complete = .true. ; if (present(complete)) block_til_complete = complete - pos = CENTER ; if (present(position)) pos = position - - if (present(inner_halo)) then ; if (inner_halo >= 0) then - ! Store the original values. - allocate(tmp(size(array,1), size(array,2))) - tmp(:,:) = array(:,:) - block_til_complete = .true. - endif ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & - complete=block_til_complete, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & - complete=block_til_complete, position=position) - endif - - if (present(inner_halo)) then ; if (inner_halo >= 0) then - call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) - ! Convert to local indices for arrays starting at 1. - isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 - jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 - i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) - - ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. - if (pos == CENTER) then - if (size(array,1) == ied) then - isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif - if (size(array,2) == jed) then - isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif - elseif (pos == CORNER) then - if (size(array,1) == ied) then - isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - elseif (size(array,1) == ied+1) then - isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) - else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif - if (size(array,2) == jed) then - jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo - elseif (size(array,2) == jed+1) then - jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) - else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif - elseif (pos == NORTH_FACE) then - if (size(array,1) == ied) then - isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif - if (size(array,2) == jed) then - jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo - elseif (size(array,2) == jed+1) then - jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) - else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif - elseif (pos == EAST_FACE) then - if (size(array,1) == ied) then - isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - elseif (size(array,1) == ied+1) then - isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) - else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif - if (size(array,2) == jed) then - isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo - else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif - else - call MOM_error(FATAL, "pass_var_2d: Unrecognized position") - endif - - ! Copy back the stored inner halo points - do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo - do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo - do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo - do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo - - deallocate(tmp) - endif ; endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_var_2d - -!> pass_var_start_2d starts a halo update for a two-dimensional array. -function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & - clock) - real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before - !! progress resumes. Omitting complete is the - !! same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & - flags=dirflag, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & - flags=dirflag, position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end function pass_var_start_2d - -!> pass_var_start_3d starts a halo update for a three-dimensional array. -function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & - clock) - real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before - !! progress resumes. Omitting complete is the - !! same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - integer :: pass_var_start_3d !< The integer index for this update. - - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & - flags=dirflag, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & - flags=dirflag, position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end function pass_var_start_3d - -!> pass_var_complete_2d completes a halo update for a two-dimensional array. -subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & - clock) - integer, intent(in) :: id_update !< The integer id of this update which has - !! been returned from a previous call to - !! pass_var_start. - real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & - flags=dirflag, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & - flags=dirflag, position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_var_complete_2d - -!> pass_var_complete_3d completes a halo update for a three-dimensional array. -subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & - clock) - integer, intent(in) :: id_update !< The integer id of this update which has - !! been returned from a previous call to - !! pass_var_start. - real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & - flags=dirflag, position=position, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & - flags=dirflag, position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_var_complete_3d - -!> pass_vector_2d does a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. -subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & - clock) - real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before progress resumes. - !! Omitting complete is the same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - ! Local variables - integer :: stagger_local - integer :: dirflag - logical :: block_til_complete - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - block_til_complete = .true. - if (present(complete)) block_til_complete = complete - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - gridtype=stagger_local, complete = block_til_complete, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - gridtype=stagger_local, complete = block_til_complete) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_vector_2d - -!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only -!! fill in the values at the edge of a pair of symmetric memory two-dimensional -!! arrays representing the compontents of a two-dimensional horizontal vector. -!! If symmetric memory is not being used, this subroutine does nothing except to -!! possibly turn optional cpu clocks on or off. -subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & - clock) - real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - logical, optional, intent(in) :: scalar !< An optional argument indicating whether. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - ! Local variables - integer :: stagger_local - integer :: dirflag - integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB - real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y - logical :: block_til_complete - - if (.not. MOM_dom%symmetric) then - return - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return - - call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) - - ! Adjust isc, etc., to account for the fact that the input arrays indices all - ! start at 1 (and are effectively on a SW grid!). - isc = isc - (isd-1) ; iec = iec - (isd-1) - jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) - IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 - - dirflag = To_All ! 60 - if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif - - if (stagger_local == CGRID_NE) then - allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) - wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 - call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - wbufferx=wbuff_x, sbuffery=sbuff_y, & - gridtype=CGRID_NE) - do i=isc,iec - v_cmpt(i,JscB) = sbuff_y(i) - enddo - do j=jsc,jec - u_cmpt(IscB,j) = wbuff_x(j) - enddo - deallocate(wbuff_x) ; deallocate(sbuff_y) - elseif (stagger_local == BGRID_NE) then - allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) - allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) - wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 - call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - wbufferx=wbuff_x, sbufferx=sbuff_x, & - wbuffery=wbuff_y, sbuffery=sbuff_y, & - gridtype=BGRID_NE) - do I=IscB,IecB - u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) - enddo - do J=JscB,JecB - u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) - enddo - deallocate(wbuff_x) ; deallocate(sbuff_x) - deallocate(wbuff_y) ; deallocate(sbuff_y) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine fill_vector_symmetric_edges_2d - -!> pass_vector_3d does a halo update for a pair of three-dimensional arrays -!! representing the compontents of a three-dimensional horizontal vector. -subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & - clock) - real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before progress resumes. - !! Omitting complete is the same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - ! Local variables - integer :: stagger_local - integer :: dirflag - logical :: block_til_complete - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - block_til_complete = .true. - if (present(complete)) block_til_complete = complete - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - gridtype=stagger_local, complete = block_til_complete, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & - gridtype=stagger_local, complete = block_til_complete) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_vector_3d - -!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. -function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & - clock) - real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before progress resumes. - !! Omitting complete is the same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - integer :: pass_vector_start_2d !< The integer index for this - !! update. - - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end function pass_vector_start_2d - -!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays -!! representing the compontents of a three-dimensional horizontal vector. -function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & - clock) - real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - logical, optional, intent(in) :: complete !< An optional argument indicating whether the - !! halo updates should be completed before progress resumes. - !! Omitting complete is the same as setting complete to .true. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - integer :: pass_vector_start_3d !< The integer index for this - !! update. - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end function pass_vector_start_3d - -!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. -subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & - clock) - integer, intent(in) :: id_update !< The integer id of this update which has been - !! returned from a previous call to - !! pass_var_start. - real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_vector_complete_2d - -!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional -!! arrays representing the compontents of a three-dimensional horizontal vector. -subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & - clock) - integer, intent(in) :: id_update !< The integer id of this update which has been - !! returned from a previous call to - !! pass_var_start. - real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & - whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) - else - call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & - MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine pass_vector_complete_3d - -!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. -subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & - halo, clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - ! Local variables - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (mpp_group_update_initialized(group)) then - call mpp_reset_group_update_field(group,array) - elseif (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & - position=position, whalo=halo, ehalo=halo, & - shalo=halo, nhalo=halo) - else - call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & - position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine create_var_group_pass_2d - -!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. -subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & - clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points - !! exchanged. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: sideflag !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, - !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. - integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is CENTER by default and is often CORNER, - !! but could also be EAST_FACE or NORTH_FACE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - ! Local variables - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - dirflag = To_All ! 60 - if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - - if (mpp_group_update_initialized(group)) then - call mpp_reset_group_update_field(group,array) - elseif (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & - position=position, whalo=halo, ehalo=halo, & - shalo=halo, nhalo=halo) - else - call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & - position=position) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine create_var_group_pass_3d - -!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. -subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & - clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (mpp_group_update_initialized(group)) then - call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) - elseif (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & - flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & - shalo=halo, nhalo=halo) - else - call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & - flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine create_vector_group_pass_2d - -!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. -subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & - clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector - !! pair which is having its halos points - !! exchanged. - real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the - !! vector pair which is having its halos points - !! exchanged. - - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: direction !< An optional integer indicating which - !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, - !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional - !! scalars discretized at the typical vector component locations. For example, TO_EAST sends - !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL - !! is the default if omitted. - integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, - !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are - !! discretized. Omitting stagger is the same as setting it to CGRID_NE. - integer, optional, intent(in) :: halo !< The size of the halo to update - the full - !! halo by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - ! Local variables - integer :: stagger_local - integer :: dirflag - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - stagger_local = CGRID_NE ! Default value for type of grid - if (present(stagger)) stagger_local = stagger - - dirflag = To_All ! 60 - if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif - - if (mpp_group_update_initialized(group)) then - call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) - elseif (present(halo) .and. MOM_dom%thin_halo_updates) then - call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & - flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & - shalo=halo, nhalo=halo) - else - call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & - flags=dirflag, gridtype=stagger_local) - endif - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine create_vector_group_pass_3d - -!> do_group_pass carries out a group halo update. -subroutine do_group_pass(group, MOM_dom, clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - real :: d_type - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine do_group_pass - -!> start_group_pass starts out a group halo update. -subroutine start_group_pass(group, MOM_dom, clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - - real :: d_type - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine start_group_pass - -!> complete_group_pass completes a group halo update. -subroutine complete_group_pass(group, MOM_dom, clock) - type(group_pass_type), intent(inout) :: group !< The data type that store information for - !! group update. This data will be used in - !! do_group_pass. - type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain - !! needed to determine where data should be - !! sent. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be - !! started then stopped to time this routine. - real :: d_type - - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif - - call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) - - if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif - -end subroutine complete_group_pass - !> 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. @@ -1189,12 +59,12 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & 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 - !! whether this domain is symmetric, regardless of - !! whether the macro SYMMETRIC_MEMORY_ is defined. + !! whether this domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. logical, optional, intent(in) :: static_memory !< If present and true, this - !! domain type is set up for static memory and error - !! checking of various input values is performed against - !! those in the input file. + !! domain type is set up for static memory and + !! error checking of various input values is + !! performed against those in the input file. integer, optional, intent(in) :: NIHALO !< Default halo sizes, required !! with static memory. integer, optional, intent(in) :: NJHALO !< Default halo sizes, required @@ -1218,28 +88,26 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !! layout-specific parameters. ! Local variables - integer, dimension(2) :: layout = (/ 1, 1 /) - integer, dimension(2) :: io_layout = (/ 0, 0 /) - integer, dimension(4) :: global_indices - !$ integer :: ocean_nthreads ! Number of Openmp threads - !$ logical :: ocean_omp_hyper_thread - integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain. - integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos. - integer :: nihalo_dflt, njhalo_dflt - integer :: pe, proc_used - logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. - logical, dimension(2,2) :: tripolar ! A set of flag indicating whether there is tripolar - ! connectivity for any of the four logical edges of the grid. - ! Currently only tripolar_N is implemented. + integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions + 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 + integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain + integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos + integer :: nihalo_dflt, njhalo_dflt ! The default halo sizes + integer :: PEs_used ! The number of processors used + logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. + logical :: tripolar_N ! A flag indicating whether there is northern tripolar connectivity logical :: is_static ! If true, static memory is being used for this domain. - logical :: is_symmetric ! True if the domainn being set up will use symmetric memory. + logical :: is_symmetric ! True if the domain being set up will use symmetric 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 :: mask_table_exists - character(len=128) :: mask_table, inputdir - character(len=64) :: inc_nm - character(len=200) :: mesg + 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 + character(len=64) :: inc_nm ! The name of the memory include file + character(len=200) :: mesg ! A string to use for error messages integer :: nip_parsed, njp_parsed character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal @@ -1249,8 +117,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & # include "version_variable.h" character(len=40) :: mdl ! This module's name. - pe = PE_here() - proc_used = num_PEs() + PEs_used = num_PEs() mdl = "MOM_domains" @@ -1295,13 +162,12 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "REENTRANT_Y", reentrant(2), & "If true, the domain is meridionally reentrant.", & default=.false.) - tripolar(1:2,1:2) = .false. - call get_param(param_file, mdl, "TRIPOLAR_N", tripolar(2,2), & + call get_param(param_file, mdl, "TRIPOLAR_N", tripolar_N, & "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) -#ifndef NOT_SET_AFFINITY +# ifndef NOT_SET_AFFINITY !$ 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.", & @@ -1310,22 +176,24 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) !$ endif -#endif +# endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", is_symmetric, & - "If defined, the velocity point data domain includes "//& - "every face of the thickness points. In other words, "//& - "some arrays are larger than others, depending on where "//& - "they are on the staggered grid. Also, the starting "//& + "If defined, the velocity point data domain includes every face of the "//& + "thickness points. In other words, some arrays are larger than others, "//& + "depending on where they are on the staggered grid. Also, the starting "//& "index of the velocity-point arrays is usually 0, not 1. "//& "This can only be set at compile time.",& layoutParam=.true.) call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & "If true, non-blocking halo updates may be used.", & default=.false., layoutParam=.true.) + !### Note the duplicated "the the" in the following description, which should be fixed as a part + ! of a larger commit that also changes other MOM_parameter_doc file messages, but for now + ! reproduces the existing output files. call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & - "If true, optional arguments may be used to specify the "//& - "the width of the halos that are updated with each call.", & + "If true, optional arguments may be used to specify the the width of the "//& + "halos that are updated with each call.", & default=.true., layoutParam=.true.) nihalo_dflt = 4 ; njhalo_dflt = 4 @@ -1333,29 +201,25 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (present(NJHALO)) njhalo_dflt = NJHALO call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & - "If STATIC_MEMORY_ is defined, the principle variables "//& - "will have sizes that are statically determined at "//& - "compile time. Otherwise the sizes are not determined "//& - "until run time. The STATIC option is substantially "//& - "faster, but does not allow the PE count to be changed "//& - "at run time. This can only be set at compile time.",& - layoutParam=.true.) + "If STATIC_MEMORY_ is defined, the principle variables will have sizes that "//& + "are statically determined at compile time. Otherwise the sizes are not "//& + "determined until run time. The STATIC option is substantially faster, but "//& + "does not allow the PE count to be changed at run time. This can only be "//& + "set at compile time.", layoutParam=.true.) if (is_static) then call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & - "The total number of thickness grid points in the "//& - "x-direction in the physical domain. With STATIC_MEMORY_ "//& - "this is set in "//trim(inc_nm)//" at compile time.", & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & static_value=NIGLOBAL) call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & - "The total number of thickness grid points in the "//& - "y-direction in the physical domain. With STATIC_MEMORY_ "//& - "this is set in "//trim(inc_nm)//" at compile time.", & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & static_value=NJGLOBAL) if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") + "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") + "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then @@ -1363,22 +227,20 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & write( char_ysiz, '(i4)' ) NJPROC write( char_niglobal, '(i4)' ) NIGLOBAL write( char_njglobal, '(i4)' ) NJGLOBAL - call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = (' & - //trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& - 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') + call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& + trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& + 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in '//trim(inc_nm)//' to use '//& - 'dynamic allocation, or change processor decomposition to evenly divide the domain.') + 'dynamic allocation, or change processor decomposition to evenly divide the domain.') endif else call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & - "The total number of thickness grid points in the "//& - "x-direction in the physical domain. With STATIC_MEMORY_ "//& - "this is set in "//trim(inc_nm)//" at compile time.", & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & - "The total number of thickness grid points in the "//& - "y-direction in the physical domain. With STATIC_MEMORY_ "//& - "this is set in "//trim(inc_nm)//" at compile time.", & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) endif @@ -1406,41 +268,32 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "static mismatch for "//trim(njhalo_nm)//" domain size") endif - global_indices(1) = 1 ; global_indices(2) = n_global(1) - global_indices(3) = 1 ; global_indices(4) = n_global(2) - 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", & + "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_exist(mask_table) + mask_table_exists = file_exists(mask_table) if (is_static) then layout(1) = NIPROC ; layout(2) = NJPROC else call get_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout to be used, or 0, 0 to automatically "//& - "set the layout based on the number of processors.", default=0, & - do_not_log=.true.) + "The processor layout to be used, or 0, 0 to automatically set the layout "//& + "based on the number of processors.", default=0, do_not_log=.true.) call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & - "The number of processors in the x-direction.", default=-1, & - do_not_log=.true.) + "The number of processors in the x-direction.", default=-1, do_not_log=.true.) call get_param(param_file, mdl, trim(njproc_nm), njp_parsed, & - "The number of processors in the y-direction.", default=-1, & - do_not_log=.true.) + "The number of processors in the y-direction.", default=-1, do_not_log=.true.) if (nip_parsed > -1) then if ((layout(1) > 0) .and. (layout(1) /= nip_parsed)) & call MOM_error(FATAL, trim(layout_nm)//" and "//trim(niproc_nm)//" set inconsistently. "//& @@ -1458,32 +311,29 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "Shift to using "//trim(layout_nm)//" instead.") endif - if ( layout(1)==0 .and. layout(2)==0 ) & - call MOM_define_layout(global_indices, proc_used, layout) - if ( layout(1)/=0 .and. layout(2)==0 ) layout(2) = proc_used/layout(1) - if ( layout(1)==0 .and. layout(2)/=0 ) layout(1) = proc_used/layout(2) + if ( (layout(1) == 0) .and. (layout(2) == 0) ) & + call MOM_define_layout( (/ 1, n_global(1), 1, n_global(2) /), PEs_used, layout) + if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) + if ( (layout(1) == 0) .and. (layout(2) /= 0) ) layout(1) = PEs_used / layout(2) - if (layout(1)*layout(2) /= proc_used .and. (.not. mask_table_exists) ) then + if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & & 2i4,", is not the number of PEs used, ",i5,".")') & - layout(1),layout(2),proc_used + layout(1), layout(2), PEs_used call MOM_error(FATAL, mesg) endif endif call log_param(param_file, mdl, trim(niproc_nm), layout(1), & - "The number of processors in the x-direction. With "//& - "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& - layoutParam=.true.) + "The number of processors in the x-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the y-direction. With "//& - "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& - layoutParam=.true.) + "The number of processors in the y-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout that was actually used.",& - layoutParam=.true.) + "The processor layout that was actually used.", layoutParam=.true.) ! Idiot check that fewer PEs than columns have been requested - if (layout(1)*layout(2)>n_global(1)*n_global(2)) then + if (layout(1)*layout(2) > n_global(1)*n_global(2)) then write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' call MOM_error(FATAL, mesg) @@ -1496,635 +346,13 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! 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.) + "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.) - call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, io_layout=io_layout, & - domain_name=domain_name, mask_table=mask_table, symmetric=symmetric, & - thin_halos=thin_halos, nonblocking=nonblocking) + 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, & + symmetric=symmetric, thin_halos=thin_halos, nonblocking=nonblocking) end subroutine MOM_domains_init -!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information -!! provided in arguments. -subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar, layout, io_layout, & - domain_name, mask_table, symmetric, thin_halos, nonblocking) - type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. - integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in - !! the i- and j-directions - integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor - logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions - logical, dimension(2,2), intent(in) :: tripolar !< If true the grid uses tripolar connectivity on the two - !! ends (first index) of the i- and j-grids (second index) - integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. - integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. - character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. - character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. - logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain - !! uses symmetric memory, or true if missing. - logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of - !! thin halo updates, or true if missing. - logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of - !! nonblocking halo updates, or false if missing. - - ! local variables - integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds - integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. - integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. - integer :: xhalo_d2, yhalo_d2 - character(len=200) :: mesg ! A string for use in error messages - character(len=64) :: dom_name ! The domain name - logical :: mask_table_exists ! Mask_table is present and the file it points to exists - - if (.not.associated(MOM_dom)) then - allocate(MOM_dom) - allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) - endif - - dom_name = "MOM" ; if (present(domain_name)) dom_name = trim(domain_name) - - X_FLAGS = 0 ; Y_FLAGS = 0 - if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN - if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN - if (tripolar(2,2)) then - Y_FLAGS = FOLD_NORTH_EDGE - if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & - "TRIPOLAR_N and REENTRANT_Y may not be used together.") - endif - - MOM_dom%nonblocking_updates = nonblocking - MOM_dom%thin_halo_updates = thin_halos - MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric - MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) - MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) - - ! Save the extra data for creating other domains of different resolution that overlay this domain. - MOM_dom%X_FLAGS = X_FLAGS - MOM_dom%Y_FLAGS = Y_FLAGS - MOM_dom%layout(:) = layout(:) - - ! Set up the io_layout, with error handling. - MOM_dom%io_layout(:) = (/ 1, 1 /) - if (present(io_layout)) then - if (io_layout(1) == 0) then - MOM_dom%io_layout(1) = layout(1) - elseif (io_layout(1) > 1) then - MOM_dom%io_layout(1) = io_layout(1) - if (modulo(layout(1), io_layout(1)) /= 0) then - write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & - &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) - call MOM_error(FATAL, mesg) - endif - endif - - if (io_layout(2) == 0) then - MOM_dom%io_layout(2) = layout(2) - elseif (io_layout(2) > 1) then - MOM_dom%io_layout(2) = io_layout(2) - if (modulo(layout(2), io_layout(2)) /= 0) then - write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & - &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) - call MOM_error(FATAL, mesg) - endif - endif - endif - - global_indices(1:4) = (/ 1, MOM_dom%niglobal, 1, MOM_dom%njglobal /) - - if (present(mask_table)) then - mask_table_exists = file_exist(mask_table) - if (mask_table_exists) then - allocate(MOM_dom%maskmap(layout(1), layout(2))) - call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) - endif - else - mask_table_exists = .false. - endif - - if (mask_table_exists) then - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name, & - maskmap=MOM_dom%maskmap ) - else - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name) - endif - - if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) - endif - - !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. - !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get - !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 - xhalo_d2 = int(MOM_dom%nihalo/2) - yhalo_d2 = int(MOM_dom%njhalo/2) - global_indices(1:4) = (/ 1, int(MOM_dom%niglobal/2), 1, int(MOM_dom%njglobal/2) /) - if (mask_table_exists) then - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry = MOM_dom%symmetric, name=trim("MOMc"), & - maskmap=MOM_dom%maskmap ) - else - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry = MOM_dom%symmetric, name=trim("MOMc")) - endif - - if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. & - (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain_d2, MOM_dom%io_layout) - endif - -end subroutine create_MOM_domain - -!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type -!! and all of its contents -subroutine deallocate_MOM_domain(MOM_domain, cursory) - type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated - logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated - !! with the underlying infrastructure - - if (associated(MOM_domain)) then - call deallocate_domain_contents(MOM_domain, cursory) - deallocate(MOM_domain) - endif - -end subroutine deallocate_MOM_domain - -!> deallocate_domain_contents deallocates memory associated with pointers -!! inside of a MOM_domain_type. -subroutine deallocate_domain_contents(MOM_domain, cursory) - type(MOM_domain_type), intent(inout) :: MOM_domain !< A MOM_domain_type whose contents will be deallocated - logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated - !! with the underlying infrastructure - - logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure - - invasive = .true. ; if (present(cursory)) invasive = .not.cursory - - if (associated(MOM_domain%mpp_domain)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) - deallocate(MOM_domain%mpp_domain) - endif - if (associated(MOM_domain%mpp_domain_d2)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) - deallocate(MOM_domain%mpp_domain_d2) - endif - if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) - -end subroutine deallocate_domain_contents - -!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. -function MOM_thread_affinity_set() - ! Local variables - !$ integer :: ocean_nthreads ! Number of openMP threads - !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads - logical :: MOM_thread_affinity_set - - MOM_thread_affinity_set = .false. - !$ call fms_affinity_init() - !$OMP PARALLEL - !$OMP MASTER - !$ ocean_nthreads = omp_get_num_threads() - !$OMP END MASTER - !$OMP END PARALLEL - !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) -end function MOM_thread_affinity_set - -!> set_MOM_thread_affinity sest the number of openMP threads to use with the ocean. -subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) - integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model - logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading - - ! Local variables - !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions - - !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) - !$ call omp_set_num_threads(ocean_nthreads) - !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() - !$ flush(6) -end subroutine set_MOM_thread_affinity - -!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain -subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) - type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted - type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain - type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain - - call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) -end subroutine get_domain_components_MD - -!> This subroutine retrieves the 1-d domains that make up a 2d-domain -subroutine get_domain_components_d2D(domain, x_domain, y_domain) - type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted - type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain - type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain - - call mpp_get_domain_components(domain, x_domain, y_domain) -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) - type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain - type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be - !! allocated if it is unassociated, and will have data - !! copied from MD_in - integer, dimension(2), & - optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the i- and j- - !! directions, and returns the actual halo size used. - integer, optional, intent(in) :: halo_size !< If present, this sets the halo - !! size for the domain in the i- and j-directions. - !! min_halo and halo_size can not both be present. - logical, optional, intent(in) :: symmetric !< If present, this specifies - !! whether the new domain is symmetric, regardless of - !! whether the macro SYMMETRIC_MEMORY_ is defined. - character(len=*), & - optional, intent(in) :: domain_name !< A name for the new domain, "MOM" - !! if missing. - integer, optional, intent(in) :: turns !< Number of quarter turns - - integer :: global_indices(4) - logical :: mask_table_exists - character(len=64) :: dom_name - integer :: qturns - - qturns = 0 - if (present(turns)) qturns = turns - - if (.not.associated(MOM_dom)) then - allocate(MOM_dom) - allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) - endif - -! Save the extra data for creating other domains of different resolution that overlay this domain - MOM_dom%symmetric = MD_in%symmetric - MOM_dom%nonblocking_updates = MD_in%nonblocking_updates - MOM_dom%thin_halo_updates = MD_in%thin_halo_updates - - if (modulo(qturns, 2) /= 0) then - MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal - MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo - - 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) - 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 - - 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(:) - endif - - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal - - if (associated(MD_in%maskmap)) then - mask_table_exists = .true. - allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) - if (qturns /= 0) then - call rotate_array(MD_in%maskmap(:,:), qturns, MOM_dom%maskmap(:,:)) - else - MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) - endif - else - mask_table_exists = .false. - endif - - if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & - "clone_MOM_domain can not have both halo_size and min_halo present.") - - if (present(min_halo)) then - MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) - min_halo(1) = MOM_dom%nihalo - MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) - min_halo(2) = MOM_dom%njhalo - endif - - if (present(halo_size)) then - MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size - endif - - if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif - - dom_name = "MOM" - if (present(domain_name)) dom_name = trim(domain_name) - - if (mask_table_exists) then - call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=dom_name, & - maskmap=MOM_dom%maskmap) - - global_indices(2) = global_indices(2) / 2 - global_indices(4) = global_indices(4) / 2 - call MOM_define_domain(global_indices, MOM_dom%layout, & - MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=dom_name, & - maskmap=MOM_dom%maskmap) - else - call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=dom_name) - - global_indices(2) = global_indices(2) / 2 - global_indices(4) = global_indices(4) / 2 - call MOM_define_domain(global_indices, MOM_dom%layout, & - MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=dom_name) - endif - - if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & - (MOM_dom%layout(1)*MOM_dom%layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) - endif - -end subroutine clone_MD_to_MD - -!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new -!! domain2d type, while allowing some properties of the new type to differ from -!! the original one. -subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & - domain_name, turns) - type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned - type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up - integer, dimension(2), & - optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the i- and j- - !! directions, and returns the actual halo size used. - integer, optional, intent(in) :: halo_size !< If present, this sets the halo - !! size for the domain in the i- and j-directions. - !! min_halo and halo_size can not both be present. - logical, optional, intent(in) :: symmetric !< If present, this specifies - !! whether the new domain is symmetric, regardless of - !! whether the macro SYMMETRIC_MEMORY_ is defined. - character(len=*), & - optional, intent(in) :: domain_name !< A name for the new domain, "MOM" - !! if missing. - integer, optional, intent(in) :: turns !< If true, swap X and Y axes - - integer :: global_indices(4), layout(2), io_layout(2) - integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo - logical :: symmetric_dom - character(len=64) :: dom_name - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") - -! Save the extra data for creating other domains of different resolution that overlay this domain - niglobal = MD_in%niglobal ; njglobal = MD_in%njglobal - nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo - - symmetric_dom = MD_in%symmetric - - X_FLAGS = MD_in%X_FLAGS ; Y_FLAGS = MD_in%Y_FLAGS - layout(:) = MD_in%layout(:) ; io_layout(:) = MD_in%io_layout(:) - - if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & - "clone_MOM_domain can not have both halo_size and min_halo present.") - - if (present(min_halo)) then - nihalo = max(nihalo, min_halo(1)) - njhalo = max(njhalo, min_halo(2)) - min_halo(1) = nihalo ; min_halo(2) = njhalo - endif - - if (present(halo_size)) then - nihalo = halo_size ; njhalo = halo_size - endif - - if (present(symmetric)) then ; symmetric_dom = symmetric ; endif - - dom_name = "MOM" - if (present(domain_name)) dom_name = trim(domain_name) - - global_indices(1) = 1 ; global_indices(2) = niglobal - global_indices(3) = 1 ; global_indices(4) = njglobal - if (associated(MD_in%maskmap)) then - call MOM_define_domain( global_indices, layout, mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=nihalo, yhalo=njhalo, & - symmetry = symmetric, name=dom_name, & - maskmap=MD_in%maskmap ) - else - call MOM_define_domain( global_indices, layout, mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=nihalo, yhalo=njhalo, & - symmetry = symmetric, name=dom_name) - endif - - if ((io_layout(1) + io_layout(2) > 0) .and. & - (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(mpp_domain, io_layout) - endif - -end subroutine clone_MD_to_d2D - -!> Returns various data that has been stored in a MOM_domain_type -subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & - isg, ieg, jsg, jeg, idg_offset, jdg_offset, & - symmetric, local_indexing, index_offset) - type(MOM_domain_type), & - intent(in) :: Domain !< The MOM domain from which to extract information - integer, intent(out) :: isc !< The start i-index of the computational domain - integer, intent(out) :: iec !< The end i-index of the computational domain - integer, intent(out) :: jsc !< The start j-index of the computational domain - integer, intent(out) :: jec !< The end j-index of the computational domain - integer, intent(out) :: isd !< The start i-index of the data domain - integer, intent(out) :: ied !< The end i-index of the data domain - integer, intent(out) :: jsd !< The start j-index of the data domain - integer, intent(out) :: jed !< The end j-index of the data domain - integer, intent(out) :: isg !< The start i-index of the global domain - integer, intent(out) :: ieg !< The end i-index of the global domain - integer, intent(out) :: jsg !< The start j-index of the global domain - integer, intent(out) :: jeg !< The end j-index of the global domain - integer, intent(out) :: idg_offset !< The offset between the corresponding global and - !! data i-index spaces. - integer, intent(out) :: jdg_offset !< The offset between the corresponding global and - !! data j-index spaces. - logical, intent(out) :: symmetric !< True if symmetric memory is used. - logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, - !! as in most MOM6 code. - integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This - !! can be useful for some types of debugging with - !! dynamic memory allocation. - ! Local variables - integer :: ind_off - logical :: local - - local = .true. ; if (present(local_indexing)) local = local_indexing - ind_off = 0 ; if (present(index_offset)) ind_off = index_offset - - call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain, isg, ieg, jsg, jeg) - - ! This code institutes the MOM convention that local array indices start at 1. - if (local) then - idg_offset = isd-1 ; jdg_offset = jsd-1 - isc = isc-isd+1 ; iec = iec-isd+1 ; jsc = jsc-jsd+1 ; jec = jec-jsd+1 - ied = ied-isd+1 ; jed = jed-jsd+1 - isd = 1 ; jsd = 1 - else - idg_offset = 0 ; jdg_offset = 0 - endif - if (ind_off /= 0) then - idg_offset = idg_offset + ind_off ; jdg_offset = jdg_offset + ind_off - isc = isc + ind_off ; iec = iec + ind_off - jsc = jsc + ind_off ; jec = jec + ind_off - isd = isd + ind_off ; ied = ied + ind_off - jsd = jsd + ind_off ; jed = jed + ind_off - endif - symmetric = Domain%symmetric - -end subroutine get_domain_extent - -subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& - isd_d2, ied_d2, jsd_d2, jed_d2,& - isg_d2, ieg_d2, jsg_d2, jeg_d2) - type(MOM_domain_type), & - intent(in) :: Domain !< The MOM domain from which to extract information - integer, intent(out) :: isc_d2 !< The start i-index of the computational domain - integer, intent(out) :: iec_d2 !< The end i-index of the computational domain - integer, intent(out) :: jsc_d2 !< The start j-index of the computational domain - integer, intent(out) :: jec_d2 !< The end j-index of the computational domain - integer, intent(out) :: isd_d2 !< The start i-index of the data domain - integer, intent(out) :: ied_d2 !< The end i-index of the data domain - integer, intent(out) :: jsd_d2 !< The start j-index of the data domain - integer, intent(out) :: jed_d2 !< The end j-index of the data domain - integer, intent(out) :: isg_d2 !< The start i-index of the global domain - integer, intent(out) :: ieg_d2 !< The end i-index of the global domain - integer, intent(out) :: jsg_d2 !< The start j-index of the global domain - integer, intent(out) :: jeg_d2 !< The end j-index of the global domain - - call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) - call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) - call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) - ! This code institutes the MOM convention that local array indices start at 1. - isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 - jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 - ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 - isd_d2 = 1 ; jsd_d2 = 1 -end subroutine get_domain_extent_dsamp2 - -!> Return the (potentially symmetric) computational domain i-bounds for an array -!! passed without index specifications (i.e. indices start at 1) based on an array size. -subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) - type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information - integer, intent(in) :: size !< The i-array size - integer, intent(out) :: is !< The computational domain starting i-index. - integer, intent(out) :: ie !< The computational domain ending i-index. - logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes - !! can be considered. - ! Local variables - logical :: sym - character(len=120) :: mesg, mesg2 - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed - - call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) - - isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 - sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric - - if (size == ied) then ; is = isc ; ie = iec - elseif (size == 1+iec-isc) then ; is = 1 ; ie = size - elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 - elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 - else - write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size - if (sym) then - write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc - else - write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc - endif - call MOM_error(FATAL, trim(mesg)//trim(mesg2)) - endif - -end subroutine get_simple_array_i_ind - - -!> Return the (potentially symmetric) computational domain j-bounds for an array -!! passed without index specifications (i.e. indices start at 1) based on an array size. -subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) - type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information - integer, intent(in) :: size !< The j-array size - integer, intent(out) :: js !< The computational domain starting j-index. - integer, intent(out) :: je !< The computational domain ending j-index. - logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes - !! can be considered. - ! Local variables - logical :: sym - character(len=120) :: mesg, mesg2 - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed - - call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) - - jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 - sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric - - if (size == jed) then ; js = jsc ; je = jec - elseif (size == 1+jec-jsc) then ; js = 1 ; je = size - elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 - elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 - else - write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size - if (sym) then - write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc - else - write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc - endif - call MOM_error(FATAL, trim(mesg)//trim(mesg2)) - endif - -end subroutine get_simple_array_j_ind - -!> Returns the global shape of h-point arrays -subroutine get_global_shape(domain, niglobal, njglobal) - type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information - integer, intent(out) :: niglobal !< i-index global size of h-point arrays - integer, intent(out) :: njglobal !< j-index global size of h-point arrays - - niglobal = domain%niglobal - njglobal = domain%njglobal -end subroutine get_global_shape - -!> Returns arrays of the i- and j- sizes of the h-point computational domains for each -!! element of the grid layout. Any input values in the extent arrays are discarded, so -!! they are effectively intent out despite their declared intent of inout. -subroutine get_layout_extents(Domain, extent_i, extent_j) - type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information - integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the - !! i-direction in each i-row of the layout - integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the - !! j-direction in each j-row of the layout - - if (allocated(extent_i)) deallocate(extent_i) - if (allocated(extent_j)) deallocate(extent_j) - allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 - allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 - call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) -end subroutine get_layout_extents - end module MOM_domains diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index c7d7e98e4b..2a54a0faa9 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -3,8 +3,8 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE, get_domain_components -use MOM_domains, only : domain1D, get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domains, only : MOM_domain_type, domain1D, get_domain_components +use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type diff --git a/src/framework/MOM_io_wrapper.F90 b/src/framework/MOM_io_wrapper.F90 index 7437b59db1..20c431b93c 100644 --- a/src/framework/MOM_io_wrapper.F90 +++ b/src/framework/MOM_io_wrapper.F90 @@ -4,8 +4,8 @@ module MOM_io_wrapper ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : allocate_rotated_array, rotate_array -use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use ensemble_manager_mod, only : get_ensemble_id diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index aadbf1ace0..050ac058e8 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -15,8 +15,8 @@ module MOM_ice_shelf use MOM_IS_diag_mediator, only : diag_mediator_init, diag_mediator_end, set_diag_mediator_grid use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_IS_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_close_registration -use MOM_domain_init, only : MOM_domains_init -use MOM_domains, only : clone_MOM_domain, pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_domains, only : MOM_domains_init, pass_var, pass_vector, clone_MOM_domain +use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_dyn_horgrid, only : rescale_dyn_horgrid_bathymetry use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe From eef0f1b9ed2e08da867d44c791259731cadb669b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 21:39:55 -0500 Subject: [PATCH 128/212] +Renamed MOM_io_wrapper to MOM_io_infra Renamed MOM_io_wrapper to MOM_io_infra and MOM_coms_wrapper to MOM_coms_infra. All answers are bitwise identical, but there are changes to module names that are only used in the framework directory. --- src/framework/MOM_coms.F90 | 6 ++--- ...OM_coms_wrapper.F90 => MOM_coms_infra.F90} | 4 ++-- src/framework/MOM_domain_infra.F90 | 2 +- src/framework/MOM_domains.F90 | 8 +++---- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/framework/MOM_interpolate.F90 | 2 +- src/framework/MOM_io.F90 | 22 +++++++++---------- .../{MOM_io_wrapper.F90 => MOM_io_infra.F90} | 4 ++-- 8 files changed, 25 insertions(+), 25 deletions(-) rename src/framework/{MOM_coms_wrapper.F90 => MOM_coms_infra.F90} (99%) rename src/framework/{MOM_io_wrapper.F90 => MOM_io_infra.F90} (99%) diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 13fc4df75d..8d1a44a0e1 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -5,9 +5,9 @@ module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING -use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs, Set_PElist, Get_PElist -use MOM_coms_wrapper, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end -use MOM_coms_wrapper, only : sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms_infra, only : PE_here, root_PE, num_PEs, Set_PElist, Get_PElist +use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end +use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs implicit none ; private diff --git a/src/framework/MOM_coms_wrapper.F90 b/src/framework/MOM_coms_infra.F90 similarity index 99% rename from src/framework/MOM_coms_wrapper.F90 rename to src/framework/MOM_coms_infra.F90 index 954f6da93c..b0a291f14c 100644 --- a/src/framework/MOM_coms_wrapper.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -1,5 +1,5 @@ !> Thin interfaces to non-domain-oriented mpp communication subroutines -module MOM_coms_wrapper +module MOM_coms_infra ! This file is part of MOM6. See LICENSE.md for the license. @@ -157,4 +157,4 @@ subroutine MOM_infra_end call fms_end() end subroutine MOM_infra_end -end module MOM_coms_wrapper +end module MOM_coms_infra diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index e97ca4e18a..ce7aa4af27 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -4,7 +4,7 @@ module MOM_domain_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array -use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs +use MOM_coms_infra, only : PE_here, root_PE, num_PEs use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index f4f3d307ac..032b479d3d 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,9 +3,9 @@ module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms_wrapper, only : PE_here, root_PE, num_PEs, broadcast -use MOM_coms_wrapper, only : sum_across_PEs, min_across_PEs, max_across_PEs -use MOM_coms_wrapper, only : MOM_infra_init, MOM_infra_end +use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast +use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs +use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, create_MOM_domain use MOM_domain_infra, only : get_domain_extent, get_domain_extent_dsamp2 use MOM_domain_infra, only : clone_MOM_domain, get_domain_components @@ -24,7 +24,7 @@ module MOM_domains use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io_wrapper, only : file_exists +use MOM_io_infra, only : file_exists use MOM_string_functions, only : slasher implicit none ; private diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index b91509cc1d..b1eb005f14 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -13,7 +13,7 @@ module MOM_horizontal_regridding use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : time_interp_extern, get_external_field_info, horiz_interp_init use MOM_interpolate, only : horiz_interp_new, horiz_interp, horiz_interp_type -use MOM_io_wrapper, only : axistype, get_axis_data +use MOM_io_infra, only : axistype, get_axis_data use MOM_time_manager, only : time_type use netcdf, only : NF90_OPEN, NF90_NOWRITE, NF90_GET_ATT, NF90_GET_VAR diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index c63c847e55..c3c78d012c 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -5,7 +5,7 @@ module MOM_interpolate use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL -use MOM_io_wrapper, only : axistype +use MOM_io_infra, only : axistype 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_fms=>time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 2a54a0faa9..b53fd87071 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -9,16 +9,16 @@ module MOM_io use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io_wrapper, only : MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data -use MOM_io_wrapper, only : file_exists, field_exists, read_field_chksum -use MOM_io_wrapper, only : open_file, close_file, field_size, fieldtype, get_filename_appendix -use MOM_io_wrapper, only : flush_file, get_file_info, get_file_atts, get_file_fields -use MOM_io_wrapper, only : get_file_times, read_data, axistype, get_axis_data -use MOM_io_wrapper, only : write_field, write_metadata, write_version_number, get_ensemble_id -use MOM_io_wrapper, only : open_namelist_file, check_nml_error, io_infra_init, io_infra_end -use MOM_io_wrapper, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE -use MOM_io_wrapper, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE -use MOM_io_wrapper, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io_infra, only : MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data +use MOM_io_infra, only : file_exists, field_exists, read_field_chksum +use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, get_filename_appendix +use MOM_io_infra, only : flush_file, get_file_info, get_file_atts, get_file_fields +use MOM_io_infra, only : get_file_times, read_data, axistype, get_axis_data +use MOM_io_infra, only : write_field, write_metadata, write_version_number, get_ensemble_id +use MOM_io_infra, only : open_namelist_file, check_nml_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_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type @@ -32,7 +32,7 @@ module MOM_io ! These interfaces are actually implemented in this file. public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init public :: var_desc, modify_vardesc, query_vardesc -! The following are simple pass throughs of routines from MOM_io_wrapper or other modules +! The following are simple pass throughs of routines from MOM_io_infra or other modules public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields public :: get_file_times, open_file, read_axis_data, read_data, read_field_chksum diff --git a/src/framework/MOM_io_wrapper.F90 b/src/framework/MOM_io_infra.F90 similarity index 99% rename from src/framework/MOM_io_wrapper.F90 rename to src/framework/MOM_io_infra.F90 index 20c431b93c..16fcff5364 100644 --- a/src/framework/MOM_io_wrapper.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -1,5 +1,5 @@ !> This module contains a thin inteface to mpp and fms I/O code -module MOM_io_wrapper +module MOM_io_infra ! This file is part of MOM6. See LICENSE.md for the license. @@ -529,4 +529,4 @@ subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) call write_field(io_unit, field_md, field, tstamp=tstamp) end subroutine MOM_write_field_0d -end module MOM_io_wrapper +end module MOM_io_infra From 58b30d85995d856b4e2225bc7ed7b60d94751baf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 22:30:36 -0500 Subject: [PATCH 129/212] +Separated MOM_error_infra from MOM_error_handler Created a separate thin error handler, MOM_error_infra.F90, to work with the MOM infrastructure routines and wrap infrastructure calls, and use this in MOM_error_handler. All answers are bitwise identical, but there is a new module. --- src/framework/MOM_domain_infra.F90 | 2 +- src/framework/MOM_error_handler.F90 | 38 ++++++++++++----------------- src/framework/MOM_error_infra.F90 | 25 +++++++++++++++++++ src/framework/MOM_io_infra.F90 | 2 +- 4 files changed, 43 insertions(+), 24 deletions(-) create mode 100644 src/framework/MOM_error_infra.F90 diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index ce7aa4af27..65cb93d151 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -6,7 +6,7 @@ module MOM_domain_infra use MOM_array_transform, only : rotate_array use MOM_coms_infra, only : PE_here, root_PE, num_PEs use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 30300d6e33..57f861e282 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -3,8 +3,8 @@ module MOM_error_handler ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_mod, only : mpp_error, NOTE, WARNING, FATAL -use mpp_mod, only : mpp_pe, mpp_root_pe, stdlog, stdout +use MOM_error_infra, only : MOM_err, NOTE, WARNING, FATAL +use MOM_error_infra, only : is_root_pe, stdlog, stdout implicit none ; private @@ -39,14 +39,8 @@ module MOM_error_handler contains -!> This returns .true. if the current PE is the root PE. -function is_root_pe() - ! This returns .true. if the current PE is the root PE. - logical :: is_root_pe - is_root_pe = .false. - if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. - return -end function is_root_pe +! is_root_pe returns .true. if the current PE is the root PE. +! function is_root_pe() !> This provides a convenient interface for writing an informative comment. subroutine MOM_mesg(message, verb, all_print) @@ -62,18 +56,18 @@ subroutine MOM_mesg(message, verb, all_print) 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 mpp_error(NOTE, message) + if (write_msg .and. (verbosity >= verb_msg)) call MOM_err(NOTE, message) end subroutine MOM_mesg -!> This provides a convenient interface for writing an mpp_error message +!> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity. subroutine MOM_error(level, message, all_print) integer, intent(in) :: level !< The verbosity level of this message 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 mpp_error message + ! This provides a convenient interface for writing an error message ! with run-time filter based on a verbosity. logical :: write_msg @@ -82,13 +76,13 @@ subroutine MOM_error(level, message, all_print) select case (level) case (NOTE) - if (write_msg.and.verbosity>=2) call mpp_error(NOTE, message) + if (write_msg.and.verbosity>=2) call MOM_err(NOTE, message) case (WARNING) - if (write_msg.and.verbosity>=1) call mpp_error(WARNING, message) + if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) case (FATAL) - if (verbosity>=0) call mpp_error(FATAL, message) + if (verbosity>=0) call MOM_err(FATAL, message) case default - call mpp_error(level, message) + call MOM_err(level, message) end select end subroutine MOM_error @@ -137,10 +131,10 @@ subroutine callTree_enter(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call mpp_error(NOTE, 'callTree: '// & + call MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) else - call mpp_error(NOTE, 'callTree: '// & + call MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) endif endif @@ -152,7 +146,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 mpp_error(NOTE, 'callTree: '// & + if (is_root_pe()) call MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) end subroutine callTree_leave @@ -168,10 +162,10 @@ subroutine callTree_waypoint(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call mpp_error(NOTE, 'callTree: '// & + call MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) else - call mpp_error(NOTE, 'callTree: '// & + call MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) endif endif diff --git a/src/framework/MOM_error_infra.F90 b/src/framework/MOM_error_infra.F90 new file mode 100644 index 0000000000..21eb14ef3d --- /dev/null +++ b/src/framework/MOM_error_infra.F90 @@ -0,0 +1,25 @@ +!> Routines for error handling and I/O management +module MOM_error_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use mpp_mod, only : MOM_err => mpp_error, NOTE, WARNING, FATAL +use mpp_mod, only : mpp_pe, mpp_root_pe, stdlog, stdout + +implicit none ; private + +public MOM_err, NOTE, WARNING, FATAL, is_root_pe, stdlog, stdout + +contains + +! MOM_err writes an error message, and may stop the run depending on the +! severity of the error. + +!> is_root_pe returns .true. if the current PE is the root PE. +function is_root_pe() + logical :: is_root_pe + is_root_pe = .false. + if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. +end function is_root_pe + +end module MOM_error_infra diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index 16fcff5364..6b80812e3d 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -6,7 +6,7 @@ module MOM_io_infra use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind -use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING use ensemble_manager_mod, only : get_ensemble_id use fms_mod, only : write_version_number, open_namelist_file, check_nml_error From 548f048278c7e13bb95e980c7ddf035a5afe5f38 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Jan 2021 23:13:37 -0500 Subject: [PATCH 130/212] +Removed time_interp_external from MOM_time_manager Removed time_interp_external_mod interfaces from MOM_time_domain.F90, and replaced calls to time_interp_external in MOM_ALE_sponge.F90 with calls coming in via MOM_iterpolate. All answers are bitwise identical. --- src/framework/MOM_interpolate.F90 | 8 +++---- src/framework/MOM_time_manager.F90 | 10 --------- .../vertical/MOM_ALE_sponge.F90 | 21 ++++++++++--------- 3 files changed, 15 insertions(+), 24 deletions(-) diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index c3c78d012c..2ded435165 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -4,14 +4,14 @@ module MOM_interpolate ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : allocate_rotated_array, rotate_array -use MOM_error_handler, only : MOM_error, FATAL -use MOM_io_infra, only : axistype -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_io_infra, only : axistype +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_fms=>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_manager_mod, only : time_type implicit none ; private diff --git a/src/framework/MOM_time_manager.F90 b/src/framework/MOM_time_manager.F90 index 229c3ded3a..0f8ced0928 100644 --- a/src/framework/MOM_time_manager.F90 +++ b/src/framework/MOM_time_manager.F90 @@ -14,9 +14,6 @@ module MOM_time_manager use time_manager_mod, only : set_calendar_type, get_calendar_type use time_manager_mod, only : JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN use time_manager_mod, only : NO_CALENDAR -use time_interp_external_mod, only : init_external_field, time_interp_external, 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 implicit none ; private @@ -29,12 +26,6 @@ module MOM_time_manager public :: get_date, set_date, increment_date, month_name, days_in_month public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR public :: set_calendar_type, get_calendar_type -public :: init_external_field -public :: time_interp_external -public :: time_interp_external_init -public :: get_external_field_size -public :: get_external_field_axes -public :: get_external_field_missing contains @@ -60,5 +51,4 @@ function real_to_time(x, err_msg) real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) end function real_to_time - end module MOM_time_manager diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 64eb80acb5..4fde518cd8 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -13,18 +13,19 @@ module MOM_ALE_sponge ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only: rotate_array -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_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_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_spatial_means, only : global_i_mean -use MOM_time_manager, only : time_type, init_external_field, get_external_field_size, time_interp_external_init -use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -643,7 +644,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) endif fld_sz(1:4)=-1 - fld_sz = get_external_field_size(CS%Ref_val(CS%fldno)%id) + call get_external_field_info(CS%Ref_val(CS%fldno)%id, 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) @@ -735,12 +736,12 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! to the current model date. CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) fld_sz(1:4)=-1 - fld_sz = get_external_field_size(CS%Ref_val_u%id) + 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) CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) fld_sz(1:4)=-1 - fld_sz = get_external_field_size(CS%Ref_val_v%id) + 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) allocate( u_val(isdB:iedB,jsd:jed, fld_sz(3)) ) From 0c4000e4fa6547a48605baca9976878361881ff1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Jan 2021 08:49:02 -0500 Subject: [PATCH 131/212] +Added diag_axis_init to MOM_diag_manager Added the new function diag_axis_init to MOM_diag_manager, with arguments and argument orders that are more appropriate for use with MOM6 than the version in the FMS diag_axis module, which it calls in turn. A MOM_domain_type is one of the new optional arguments, along with a level of grid refinement and a flag indicating that the null_axis id should be returned. Calls to diag_axis_init throughout the MOM6 code have been made consistent with this new interface. All answers are bitwise identical. --- src/framework/MOM_diag_manager.F90 | 74 +++++++++++++++++-- src/framework/MOM_diag_mediator.F90 | 51 +++++++------ src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 18 ++--- src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- 4 files changed, 99 insertions(+), 46 deletions(-) diff --git a/src/framework/MOM_diag_manager.F90 b/src/framework/MOM_diag_manager.F90 index 0c9f875bcd..851001bc34 100644 --- a/src/framework/MOM_diag_manager.F90 +++ b/src/framework/MOM_diag_manager.F90 @@ -3,21 +3,23 @@ module MOM_diag_manager ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_time_manager, only : time_type -use diag_axis_mod, only : diag_axis_init, get_diag_axis_name, EAST, NORTH -use diag_data_mod, only : null_axis_id +use diag_axis_mod, only : axis_init=>diag_axis_init, get_diag_axis_name, EAST, NORTH +use diag_data_mod, only : null_axis_id use diag_manager_mod, only : diag_manager_init, diag_manager_end use diag_manager_mod, only : send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND use diag_manager_mod, only : 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_domain_infra, only : MOM_domain_type, domain2d +use MOM_error_infra, only : MOM_error=>MOM_err, FATAL +use MOM_time_manager, only : time_type implicit none ; private -public diag_manager_init, diag_manager_end -public diag_axis_init, get_diag_axis_name, EAST, NORTH, null_axis_id -public send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND -public register_diag_field_fms, register_static_field_fms, get_diag_field_id_fms +public :: diag_manager_init, diag_manager_end +public :: diag_axis_init, get_diag_axis_name, EAST, NORTH +public :: send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND +public :: register_diag_field_fms, register_static_field_fms, get_diag_field_id_fms !> A wrapper for register_diag_field_array() interface register_diag_field_fms @@ -94,6 +96,64 @@ integer function register_diag_field_scalar_fms(module_name, field_name, init_ti end function register_diag_field_scalar_fms +!> diag_axis_init stores up the information for an axis that can be used for diagnostics and +!! returns an integer hadle for this axis. +integer function diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + direction, edges, set_name, refine, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: refine !< An optional degree of refinement for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: refinement ! The degree of grid refinement + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + refinement = 1 ; if (present(refine)) refinement = refine + if (refinement == 1) then + diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain, domain_position=position) + elseif (refinement == 2) then + diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain_d2, domain_position=position) + else + call MOM_error(FATAL, "diag_axis_init called with an invalid value of refine.") + endif + else + if (present(refine)) then ; if (refine /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid refinement without a MOM_domain.") + endif ; endif + diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function diag_axis_init + !> \namespace mom_diag_manager !! !! This module simply wraps register_diag_field() from FMS's diag_manager_mod. diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 071585a951..7a462503ea 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -10,7 +10,7 @@ module MOM_diag_mediator 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_manager, only : diag_manager_init, diag_manager_end -use MOM_diag_manager, only : diag_axis_init, get_diag_axis_name, null_axis_id +use MOM_diag_manager, only : diag_axis_init, get_diag_axis_name use MOM_diag_manager, only : send_data, diag_field_add_attribute, EAST, NORTH use MOM_diag_manager, only : register_diag_field_fms, register_static_field_fms use MOM_diag_manager, only : get_diag_field_id_fms, DIAG_FIELD_NOT_FOUND @@ -345,7 +345,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) logical, optional, intent(in) :: set_vertical !< If true or missing, set up !! vertical axes ! Local variables - integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh + 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, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) @@ -380,39 +380,39 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) if (G%symmetric) then if (diag_cs%grid_space_axes) then id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & - 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'q point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & - 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'q point grid space latitude', G%Domain, position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'q point nominal longitude', G%Domain, position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'q point nominal latitude', G%Domain, position=NORTH) endif else if (diag_cs%grid_space_axes) then id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & - 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'q point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & - 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'q point grid space latitude', G%Domain, position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'q point nominal longitude', G%Domain, position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'q point nominal latitude', G%Domain, position=NORTH) endif endif 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'h point grid-space longitude', G%Domain, position=EAST) id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & - 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'h point grid space latitude', G%Domain, position=NORTH) else id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + 'h point nominal longitude', G%Domain) id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) + 'h point nominal latitude', G%Domain) endif if (set_vert) then @@ -420,11 +420,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) zinter(1:nz+1) = GV%sInterface(1:nz+1) zlev(1:nz) = GV%sLayer(1:nz) id_zl = diag_axis_init('zl', zlev, trim(GV%zAxisUnits), 'z', & - 'Layer '//trim(GV%zAxisLongName), & - direction=GV%direction) + 'Layer '//trim(GV%zAxisLongName), direction=GV%direction) id_zi = diag_axis_init('zi', zinter, trim(GV%zAxisUnits), 'z', & - 'Interface '//trim(GV%zAxisLongName), & - direction=GV%direction) + 'Interface '//trim(GV%zAxisLongName), direction=GV%direction) else id_zl = -1 ; id_zi = -1 endif @@ -473,8 +471,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - ! Axis group for special null axis from diag manager. (Could null_axis_id be made MOM specific?) - call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) + ! Axis group for special null axis from diag manager. + id_null = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.) + call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull) !Non-native Non-downsampled if (diag_cs%num_diag_coords>0) then @@ -602,9 +601,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + 'q point nominal longitude', G%Domain, refine=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + 'q point nominal latitude', G%Domain, refine=2) deallocate(gridLonB_dsamp,gridLatB_dsamp) else allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) @@ -612,9 +611,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + 'q point nominal longitude', G%Domain, refine=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + 'q point nominal latitude', G%Domain, refine=2) deallocate(gridLonB_dsamp,gridLatB_dsamp) endif @@ -623,9 +622,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + 'h point nominal longitude', G%Domain, refine=2) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + 'h point nominal latitude', G%Domain, refine=2) deallocate(gridLonT_dsamp,gridLatT_dsamp) diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 397696c0ba..4955dd291a 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -151,27 +151,21 @@ subroutine set_axes_info(G, param_file, diag_cs, axes_set_name) if (G%symmetric) then id_xq = diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'Boundary point nominal longitude',set_name=set_name, & - Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) id_yq = diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'Boundary point nominal latitude', set_name=set_name, & - Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) else id_xq = diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'Boundary point nominal longitude',set_name=set_name, & - Domain2=G%Domain%mpp_domain, domain_position=EAST) + 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) id_yq = diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'Boundary point nominal latitude', set_name=set_name, & - Domain2=G%Domain%mpp_domain, domain_position=NORTH) + 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) endif id_xh = diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'T point nominal longitude', set_name=set_name, & - Domain2=G%Domain%mpp_domain) + 'T point nominal longitude', G%Domain, set_name=set_name) id_yh = diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'T point nominal latitude', set_name=set_name, & - Domain2=G%Domain%mpp_domain) + 'T point nominal latitude', G%Domain, set_name=set_name) ! Axis groupings for 2-D arrays. call defineAxes(diag_cs, [id_xh, id_yh], diag_cs%axesT1) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 670be5d3fb..2bd90da5fe 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -14,7 +14,7 @@ module MOM_oda_driver_mod use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain use mpp_domains_mod, only : mpp_redistribute, mpp_broadcast_domain use mpp_domains_mod, only : set_domains_stack_size=>mpp_domains_set_stack_size -use diag_manager_mod, only : register_diag_field, diag_axis_init, send_data +use diag_manager_mod, only : register_diag_field, send_data use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist use time_manager_mod, only : time_type, decrement_time, increment_time From 6b24190c68e554d216e877528eb78c2ff72bce71 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 15 Jan 2021 12:38:36 -0500 Subject: [PATCH 132/212] update analysis time after call to oda , consistent with SPEAR configurations --- src/core/MOM.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f11ce42407..7d4d9b73cb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -880,12 +880,12 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo ; endif if (CS%ensemble_ocean) then - ! update the time for the next analysis step if needed - call set_analysis_time(CS%Time,CS%odaCS) ! store ensemble vector in odaCS call set_prior_tracer(CS%Time, G, GV, CS%h, CS%tv, CS%odaCS) ! call DA interface call oda(CS%Time,CS%odaCS) + ! update the time for the next analysis step if needed + call set_analysis_time(CS%Time,CS%odaCS) endif if (showCallTree) call callTree_waypoint("calling extract_surface_state (step_MOM)") From b6ce7c74257db76a47c93ddd72b0f7db8b0cfb9b Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 15 Jan 2021 12:41:06 -0500 Subject: [PATCH 133/212] pass through interfaces for mpp_broadcast_domain and mpp_set_root_pe --- src/framework/MOM_coms.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 0c6b948980..c6f3fe6dd5 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -10,17 +10,19 @@ module MOM_coms use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist use mpp_mod, only : broadcast => mpp_broadcast +use mpp_domains_mod, only : broadcast_domain => mpp_broadcast_domain +use mpp_mod, only : set_rootPE => mpp_set_root_pe use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end -public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: broadcast, broadcast_domain, sum_across_PEs, min_across_PEs, max_across_PEs public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) public :: query_EFP_overflow_error, reset_EFP_overflow_error -public :: Set_PElist, Get_PElist +public :: Set_PElist, Get_PElist, Set_rootPE ! This module provides interfaces to the non-domain-oriented communication subroutines. From bfdbe211519cfb5874c5a93febbfa5cbf7022809 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 15 Jan 2021 12:42:58 -0500 Subject: [PATCH 134/212] New interfaces for array redistribution across domains. --- src/framework/MOM_domains.F90 | 47 ++++++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 46cc9c526a..1567546885 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -30,6 +30,8 @@ module MOM_domains 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 mpp_domains_mod, only : global_field => mpp_global_field +use mpp_domains_mod, only : mpp_redistribute use fms_io_mod, only : file_exist, parse_mask_table use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get @@ -48,7 +50,7 @@ module MOM_domains public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape public :: get_simple_array_i_ind, get_simple_array_j_ind -public :: domain2D +public :: domain2D, global_field, redistribute_array !> Do a halo update on an array interface pass_var @@ -100,6 +102,11 @@ module MOM_domains module procedure clone_MD_to_MD, clone_MD_to_d2D end interface clone_MOM_domain +!> Pass an array from one MOM domain to another +interface redistribute_array + module procedure redistribute_array_3d, redistribute_array_2d +end interface redistribute_array + !> The MOM_domain_type contains information about the domain decompositoin. type, public :: MOM_domain_type type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos @@ -1979,4 +1986,42 @@ subroutine get_global_shape(domain, niglobal, njglobal) end subroutine get_global_shape +!> Returns various data that has been stored in a MOM_domain_type +subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_2d + +!> Returns various data that has been stored in a MOM_domain_type +subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_3d + end module MOM_domains From 18aff413ac7561193e48992299591bde7c698d5c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 15 Jan 2021 12:44:08 -0500 Subject: [PATCH 135/212] Replace FMS infrastructure specific calls with equivalent MOM interfaces --- src/ocean_data_assim/MOM_oda_driver.F90 | 157 +++++++++++++----------- 1 file changed, 86 insertions(+), 71 deletions(-) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 670be5d3fb..a85f9c8484 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,29 +1,27 @@ !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod - ! This file is part of MOM6. see LICENSE.md for the license. - -use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe -use mpp_mod, only : set_current_pelist => mpp_set_current_pelist -use mpp_mod, only : set_root_pe => mpp_set_root_pe -use mpp_mod, only : mpp_sync_self, mpp_sum, get_pelist=>mpp_get_current_pelist, mpp_root_pe -use mpp_mod, only : set_stack_size=>mpp_set_stack_size, broadcast=>mpp_broadcast -use mpp_io_mod, only : io_set_stack_size=>mpp_io_set_stack_size -use mpp_io_mod, only : MPP_SINGLE,MPP_MULTI -use mpp_domains_mod, only : domain2d, mpp_global_field -use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain -use mpp_domains_mod, only : mpp_redistribute, mpp_broadcast_domain -use mpp_domains_mod, only : set_domains_stack_size=>mpp_domains_set_stack_size -use diag_manager_mod, only : register_diag_field, diag_axis_init, send_data -use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size -use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist -use time_manager_mod, only : time_type, decrement_time, increment_time -use time_manager_mod, only : get_date, operator(>=),operator(/=),operator(==),operator(<) -use constants_mod, only : radius, epsln +! This file is part of MOM6. see LICENSE.md for the license. + +! MOM infrastructure +use MOM_error_handler, only : stdout, stdlog, MOM_error +use MOM_coms, only : PE_here, num_PEs +use MOM_coms, only : set_PElist, set_rootPE, Get_PElist, broadcast, broadcast_domain +use MOM_io, only : SINGLE_FILE +use MOM_domains, only : domain2d, global_field, get_domain_extent +use MOM_domains, only : pass_var, redistribute_array +use MOM_diag_mediator, only : register_diag_field, diag_axis_init, post_data +use MOM_ensemble_manager, only : get_ensemble_id, get_ensemble_size +use MOM_ensemble_manager, only : get_ensemble_pelist, get_ensemble_filter_pelist +use MOM_time_manager, only : time_type, real_to_time, get_date +use MOM_time_manager, only : operator(+), operator(>=), operator(/=) +use MOM_time_manager, only : operator(==),operator(<) ! ODA Modules use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct use ocean_da_core_mod, only : ocean_da_core_init, get_profiles -!use eakf_oda_mod, only : ensemble_filter +#ifdef ENABLE_ECDA +use eakf_oda_mod, only : ensemble_filter +#endif use write_ocean_obs_mod, only : open_profile_file use write_ocean_obs_mod, only : write_profile,close_profile_file use kdtree, only : kd_root !# JEDI @@ -57,6 +55,11 @@ module MOM_oda_driver_mod #include +!> A structure with a pointer to a domain2d, to allow for the creation of arrays of pointers. +type :: ptr_mpp_domain + type(domain2d), pointer :: mpp_domain => NULL() !< pointer to a domain2d +end type ptr_mpp_domain + !> Control structure that contains a transpose of the ocean state across ensemble members. type, public :: ODA_CS ; private type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space @@ -64,7 +67,7 @@ module MOM_oda_driver_mod !! or increments to prior in DA space integer :: nk !< number of vertical layers used for DA type(ocean_grid_type), pointer :: Grid => NULL() !< MOM6 grid type and decomposition for the DA - type(ptr_mpp_domain), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects + type(MOM_domain_type), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects !! for ensemble members type(verticalGrid_type), pointer :: GV => NULL() !< vertical grid for DA type(unit_scale_type), pointer :: & @@ -98,10 +101,6 @@ module MOM_oda_driver_mod type(diag_ctrl) :: diag_cs ! A structure with a pointer to a domain2d, to allow for the creation of arrays of pointers. -type :: ptr_mpp_domain - type(domain2d), pointer :: mpp_domain => NULL() !< pointer to an mpp domain2d -end type ptr_mpp_domain !>@{ DA parameters integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 @@ -130,6 +129,8 @@ subroutine init_oda(Time, G, GV, CS) type(param_file_type) :: PF integer :: n, m, k, i, j, nk integer :: is,ie,js,je,isd,ied,jsd,jed + integer :: isg,ieg,jsg,jeg + integer :: idg_offset, jdg_offset integer :: stdout_unit character(len=32) :: assim_method integer :: npes_pm, ens_info(6), ni, nj @@ -139,7 +140,7 @@ subroutine init_oda(Time, G, GV, CS) character(len=200) :: inputdir, basin_file logical :: reentrant_x, reentrant_y, tripolar_N, symmetric - if (associated(CS)) call mpp_error(FATAL, 'Calling oda_init with associated control structure') + if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) ! Use ens1 parameters , this could be changed at a later time ! if it were desirable to have alternate parameters, e.g. for the grid @@ -182,7 +183,7 @@ subroutine init_oda(Time, G, GV, CS) case('no_assim') CS%assim_method = NO_ASSIM case default - call mpp_error(FATAL, 'Invalid assimilation method provided') + call MOM_error(FATAL, "Invalid assimilation method provided") end select ens_info = get_ensemble_size() @@ -195,16 +196,16 @@ subroutine init_oda(Time, G, GV, CS) call get_ensemble_pelist(CS%ensemble_pelist, 'ocean') call get_ensemble_filter_pelist(CS%filter_pelist, 'ocean') - call set_current_pelist(CS%filter_pelist) + call set_PElist(CS%filter_pelist) allocate(CS%domains(CS%ensemble_size)) CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain do n=1,CS%ensemble_size if (.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) - call set_root_pe(CS%ensemble_pelist(n,1)) - call mpp_broadcast_domain(CS%domains(n)%mpp_domain) + call set_rootPE(CS%ensemble_pelist(n,1)) + call broadcast_domain(CS%domains(n)%mpp_domain) enddo - call set_root_pe(CS%filter_pelist(1)) + call set_rootPE(CS%filter_pelist(1)) allocate(CS%Grid) ! params NIHALO_ODA, NJHALO_ODA set the DA halo size call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') @@ -239,7 +240,12 @@ subroutine init_oda(Time, G, GV, CS) call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') call initialize_remapping(CS%remapCS,'PLM') call set_regrid_params(CS%regridCS, min_thickness=0.) - call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) + ! breaking with the MOM6 convention and using global indices + call get_domain_extent(G%Domain,is,ie,js,je,isd,ied,jsd,jed,& + isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) + isd=isd+idg_offset; ied=ied+idg_offset + jsd=jsd+jdg_offset; jed=jed+jdg_offset + !call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) if (.not. associated(CS%h)) then allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke)); CS%h(:,:,:)=0.0 ! assign thicknesses @@ -247,10 +253,13 @@ subroutine init_oda(Time, G, GV, CS) endif allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%T(:,:,:)=0.0 allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 - call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) - - call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) + ! get domain extents for the analysis grid and use global indexing + !call get_domain_extent(CS%Grid%Domain,is,ie,js,je,isd,ied,jsd,jed,& + ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) + !isd=isd+idg_offset; ied=ied+idg_offset + !jsd=jsd+jdg_offset; jed=jed+jdg_offset + !call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) allocate(CS%oda_grid) CS%oda_grid%x => CS%Grid%geolonT CS%oda_grid%y => CS%Grid%geolatT @@ -268,9 +277,9 @@ subroutine init_oda(Time, G, GV, CS) allocate(T_grid%x(CS%ni,CS%nj)) allocate(T_grid%y(CS%ni,CS%nj)) allocate(T_grid%basin_mask(CS%ni,CS%nj)) - call mpp_global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) - call mpp_global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) - call mpp_global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) + call global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) + call global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) + call global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) T_grid%ni = CS%ni T_grid%nj = CS%nj T_grid%nk = CS%nk @@ -282,7 +291,7 @@ subroutine init_oda(Time, G, GV, CS) T_grid%z(:,:,:) = 0.0 do k = 1, CS%nk - call mpp_global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) + call global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) do i=1,CS%ni ; do j=1,CS%nj if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 @@ -300,7 +309,7 @@ subroutine init_oda(Time, G, GV, CS) CS%Time=Time !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) end subroutine init_oda !> Copy ensemble member tracers to ensemble vector. @@ -312,14 +321,15 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ODA_CS), pointer :: CS !< ocean DA control structure - real, dimension(:,:,:), allocatable :: T, S + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: T, S type(ocean_grid_type), pointer :: Grid=>NULL() integer :: i,j, m, n, ss integer :: is, ie, js, je integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed + integer :: isg, ieg, jsg, jeg, idg_offset, jdg_offset integer :: id - logical :: used + logical :: used, symmetric ! return if not time for analysis if (Time < CS%Time) return @@ -328,32 +338,36 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) if (.not. associated(CS%GV)) call MOM_ERROR(FATAL,'ODA_CS ensemble vertical grid not associated') !! switch to global pelist - call set_current_pelist(CS%filter_pelist) + call set_PElist(CS%filter_pelist) call MOM_mesg('Setting prior') + ! computational domain for the analysis grid isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec - call mpp_get_compute_domain(CS%domains(CS%ensemble_id)%mpp_domain,is,ie,js,je) - call mpp_get_data_domain(CS%domains(CS%ensemble_id)%mpp_domain,isd,ied,jsd,jed) - allocate(T(isd:ied,jsd:jed,CS%nk)) - allocate(S(isd:ied,jsd:jed,CS%nk)) - - do j=js,je ; do i=is,ie + ! array extents for the ensemble member + !call get_domain_extent(CS%domains(CS%ensemble_id),is,ie,js,je,isd,ied,jsd,jed,& + ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) + ! remap temperature and salinity from the ensemble member to the analysis grid + do j=G%jsc,G%jec ; do i=G%isc,G%iec call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & CS%nk, CS%h(i,j,:), T(i,j,:)) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & CS%nk, CS%h(i,j,:), S(i,j,:)) enddo ; enddo - + ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size - call mpp_redistribute(CS%domains(m)%mpp_domain, T,& + call redistribute_array(CS%domains(m)%mpp_domain, T,& CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) - call mpp_redistribute(CS%domains(m)%mpp_domain, S,& + call redistribute_array(CS%domains(m)%mpp_domain, S,& CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) enddo - deallocate(T,S) + + do m=1,CS%ensemble_size + call pass_var(CS%Ocean_prior%T(:,:,:,m),CS%Grid%domain) + call pass_var(CS%Ocean_prior%S(:,:,:,m),CS%Grid%domain) + enddo !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) return @@ -377,7 +391,7 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) !! switch to global pelist - call set_current_pelist(CS%filter_pelist) + call set_PElist(CS%filter_pelist) call MOM_mesg('Getting posterior') get_inc = .true. @@ -391,26 +405,26 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) endif do m=1,CS%ensemble_size if (get_inc) then - call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) - call mpp_redistribute(CS%mpp_domain, Ocean_increment%S(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + call redistribute_array(CS%mpp_domain, Ocean_increment%T(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call redistribute_array(CS%mpp_domain, Ocean_increment%S(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) else - call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) - call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) endif enddo tv => CS%tv h => CS%h !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) end subroutine get_posterior_tracer -!> Gather observations and sall ODA routines +!> Gather observations and call ODA routines subroutine oda(Time, CS) type(time_type), intent(in) :: Time !< the current model time type(oda_CS), intent(inout) :: CS !< the ocean DA control structure @@ -422,7 +436,7 @@ subroutine oda(Time, CS) if ( Time >= CS%Time ) then !! switch to global pelist - call set_current_pelist(CS%filter_pelist) + call set_PElist(CS%filter_pelist) call get_profiles(Time, CS%Profiles, CS%CProfiles) #ifdef ENABLE_ECDA @@ -430,7 +444,7 @@ subroutine oda(Time, CS) #endif !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) endif @@ -479,7 +493,8 @@ subroutine set_analysis_time(Time,CS) integer :: yr, mon, day, hr, min, sec if (Time >= CS%Time) then - CS%Time=increment_time(CS%Time,CS%assim_frequency*3600) + ! 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.)) call get_date(Time, yr, mon, day, hr, min, sec) write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec @@ -505,11 +520,11 @@ subroutine save_obs_diff(filename,CS) integer :: fid ! profile file handle type(ocean_profile_type), pointer :: Prof=>NULL() - fid = open_profile_file(trim(filename), nvar=2, thread=MPP_SINGLE, fset=MPP_SINGLE) + fid = open_profile_file(trim(filename), nvar=2, thread=SINGLE_FILE, fset=SINGLE_FILE) Prof=>CS%CProfiles !! switch to global pelist - !call set_current_pelist(CS%filter_pelist) + !call set_PElist(CS%filter_pelist) do while (associated(Prof)) call write_profile(fid,Prof) @@ -518,7 +533,7 @@ subroutine save_obs_diff(filename,CS) call close_profile_file(fid) !! switch back to ensemble member pelist - !call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + !call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) return end subroutine save_obs_diff From 408e3a402a242639a9599b174809c91b9f00846c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 15 Jan 2021 12:47:11 -0500 Subject: [PATCH 136/212] Pass through interface to FMS ensemble manager --- src/framework/MOM_ensemble_manager.F90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 src/framework/MOM_ensemble_manager.F90 diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90 new file mode 100644 index 0000000000..191dd79c9a --- /dev/null +++ b/src/framework/MOM_ensemble_manager.F90 @@ -0,0 +1,14 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size +use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist + +implicit none ; private + +public get_ensemble_id, get_ensemble_size, get_ensemble_pelist, get_ensemble_filter_pelist + + +end module MOM_ensemble_manager From e29a12b80a5fbcded3ee50ffa26f2ec1dd0d9ff2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 Jan 2021 15:19:19 -0500 Subject: [PATCH 137/212] Adds a GH workflow to check driver APIs - Checks that MOM6 can be compiled with the various coupled drivers. --- .github/workflows/coupled-api.yml | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 .github/workflows/coupled-api.yml diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml new file mode 100644 index 0000000000..4380f102ea --- /dev/null +++ b/.github/workflows/coupled-api.yml @@ -0,0 +1,30 @@ +name: API for coupled drivers + +on: [push, pull_request] + +jobs: + test-top-api: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v2 + with: + submodules: recursive + + - uses: ./.github/actions/testing-setup + + - name: Compile MOM6 for the GFDL coupled driver + shell: bash + run: make check_mom6_api_coupled -j + + - 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 From eb0c03a3dd80c04f69a6b685ffb1553f20ed04e0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 Jan 2021 16:09:55 -0500 Subject: [PATCH 138/212] Avoid unnecessary steps in actions/testing_setup - We spent 1 minute build symmetric unnecessarily when checking the coupled APIs --- .github/actions/testing-setup/action.yml | 13 +++++++++++-- .github/workflows/coupled-api.yml | 3 +++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml index c6fae4ad58..c47270af0d 100644 --- a/.github/actions/testing-setup/action.yml +++ b/.github/actions/testing-setup/action.yml @@ -1,5 +1,14 @@ name: 'Build-.testing-prerequisites' description: 'Build pre-requisites for .testing including FMS and a symmetric MOM6 executable' +inputs: + build_symmetric: + 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: @@ -51,7 +60,7 @@ runs: run: | echo "::group::Compile MOM6 in symmetric memory mode" cd .testing - make build/symmetric/MOM6 -j + test ${{ inputs.build_symmetric }} == true && make build/symmetric/MOM6 -j echo "::endgroup::" - name: Install local python venv for generating input data @@ -59,7 +68,7 @@ runs: run: | echo "::group::Create local python env for input data generation" cd .testing - make work/local-env + test ${{ inputs.install_python }} == true && make work/local-env echo "::endgroup::" - name: Set flags diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 4380f102ea..86d7262548 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -16,6 +16,9 @@ jobs: submodules: recursive - uses: ./.github/actions/testing-setup + with: + build_symmetric: 'false' + install_python: 'false' - name: Compile MOM6 for the GFDL coupled driver shell: bash From 8b73eb1a6c6be9d289e950bf86f360058ef88aa2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Jan 2021 10:55:06 -0500 Subject: [PATCH 139/212] +Added MOM_write_file to MOM_io Moved the overloaded interface MOM_write_file to MOM_io and renamed MOM_write_field in MOM_io_infra to write_field after removing all of the optional turns arguments and the code to rotate arrays. Also added a variant of write_field to work on axis types. The unused fill_value optional arguments were also removed from the 1-d and scalar versions of this write_field. All answers are bitwise identical, but there are interface changes that are localized to the MOM_io modules. --- src/framework/MOM_io.F90 | 142 ++++++++++++++++++++++++++++++--- src/framework/MOM_io_infra.F90 | 136 +++++++++++-------------------- 2 files changed, 179 insertions(+), 99 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index b53fd87071..8060b7b233 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -3,18 +3,19 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_domains, only : MOM_domain_type, domain1D, get_domain_components use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io_infra, only : MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data -use MOM_io_infra, only : file_exists, field_exists, read_field_chksum -use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, get_filename_appendix -use MOM_io_infra, only : flush_file, get_file_info, get_file_atts, get_file_fields -use MOM_io_infra, only : get_file_times, read_data, axistype, get_axis_data -use MOM_io_infra, only : write_field, write_metadata, write_version_number, get_ensemble_id +use MOM_io_infra, only : MOM_read_data, read_data, MOM_read_vector, read_field_chksum +use MOM_io_infra, only : file_exists, get_file_info, get_file_atts, get_file_fields +use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, field_exists +use MOM_io_infra, only : flush_file, get_filename_appendix, get_ensemble_id +use MOM_io_infra, only : get_file_times, axistype, get_axis_data, read_axis_data +use MOM_io_infra, only : write_field, write_metadata, write_version_number use MOM_io_infra, only : open_namelist_file, check_nml_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 @@ -31,12 +32,12 @@ module MOM_io ! These interfaces are actually implemented in this file. public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init -public :: var_desc, modify_vardesc, query_vardesc +public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc ! The following are simple pass throughs of routines from MOM_io_infra or other modules public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields -public :: get_file_times, open_file, read_axis_data, read_data, read_field_chksum -public :: MOM_read_data, MOM_read_vector, MOM_write_field, get_axis_data +public :: get_file_times, open_file, read_axis_data, get_axis_data +public :: MOM_read_data, MOM_read_vector, read_data, read_field_chksum public :: slasher, write_field, write_version_number public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end ! These are encoding constants. @@ -44,7 +45,16 @@ module MOM_io public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE public :: CENTER, CORNER, NORTH_FACE, EAST_FACE -!> Type for describing a variable, typically a tracer +!> Write a registered field to an output file, potentially with rotation +interface MOM_write_field + module procedure MOM_write_field_4d + module procedure MOM_write_field_3d + module procedure MOM_write_field_2d + module procedure MOM_write_field_1d + module procedure MOM_write_field_0d +end interface MOM_write_field + +!> Type for describing a 3-d variable for output type, public :: vardesc character(len=64) :: name !< Variable name in a NetCDF file character(len=48) :: units !< Physical dimensions of the variable @@ -667,6 +677,118 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & end subroutine query_vardesc + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, 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) + call write_field(io_unit, 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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, 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) + call write_field(io_unit, 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_unit, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + 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, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, 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) + call write_field(io_unit, 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_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) + integer, intent(in) :: io_unit !< File I/O unit handle + 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 + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine MOM_write_field_0d + + !> Copies a string subroutine safe_string_copy(str1, str2, fieldnm, caller) character(len=*), intent(in) :: str1 !< The string being copied diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index 6b80812e3d..f699290dc3 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -3,7 +3,6 @@ module MOM_io_infra ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING @@ -14,7 +13,7 @@ module MOM_io_infra use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix use mpp_domains_mod, only : domain2d, CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST use mpp_io_mod, only : mpp_open, close_file=>mpp_close -use mpp_io_mod, only : write_metadata=>mpp_write_meta, write_field=>mpp_write +use mpp_io_mod, only : write_metadata=>mpp_write_meta, mpp_write use mpp_io_mod, only : get_field_atts=>mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data use mpp_io_mod, only : mpp_get_fields, fieldtype, flush_file=>mpp_flush @@ -29,13 +28,13 @@ module MOM_io_infra implicit none ; private ! These interfaces are actually implemented in this file. -public :: MOM_read_data, MOM_read_vector, MOM_write_field, read_axis_data +public :: MOM_read_data, MOM_read_vector, write_field, read_axis_data public :: file_exists, field_exists, read_field_chksum ! The following are simple pass throughs of routines from other modules. public :: open_file, close_file, field_size, fieldtype, get_filename_appendix public :: flush_file, get_file_info, get_file_atts, get_file_fields, get_field_atts public :: get_file_times, read_data, axistype, get_axis_data -public :: write_field, write_metadata, write_version_number, get_ensemble_id +public :: write_metadata, write_version_number, get_ensemble_id public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end ! These are encoding constants. public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE @@ -58,13 +57,14 @@ module MOM_io_infra end interface !> Write a registered field to an output file -interface MOM_write_field - module procedure MOM_write_field_4d - module procedure MOM_write_field_3d - module procedure MOM_write_field_2d - module procedure MOM_write_field_1d - module procedure MOM_write_field_0d -end interface MOM_write_field +interface write_field + module procedure write_field_4d + module procedure write_field_3d + module procedure write_field_2d + module procedure write_field_1d + module procedure write_field_0d + module procedure MOM_write_axis +end interface write_field !> Read a pair of data fields representing the two components of a vector from a file interface MOM_read_vector @@ -417,116 +417,74 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data end subroutine MOM_read_vector_3d -!> Write a 4d field to an output file, potentially with rotation -subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) +!> Write a 4d field to an output file. +subroutine write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) integer, intent(in) :: io_unit !< File I/O unit handle 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, dimension(:,:,:,:), intent(inout) :: field !< 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, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field + call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_4d - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) - - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) +!> Write a 3d field to an output file. +subroutine write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) integer, intent(in) :: io_unit !< File I/O unit handle 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, dimension(:,:,:), intent(inout) :: field !< 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, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) + call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_3d - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) +!> Write a 2d field to an output file. +subroutine write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) integer, intent(in) :: io_unit !< File I/O unit handle 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, dimension(:,:), intent(inout) :: field !< 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, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units - integer :: qturns ! The number of quarter turns through which to rotate field - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) + call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_2d - if (qturns == 0) then - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) - else - call allocate_rotated_array(field, [1,1], qturns, field_rot) - call rotate_array(field, qturns, field_rot) - call write_field(io_unit, field_md, MOM_domain%mpp_domain, field_rot, tstamp=tstamp, & - tile_count=tile_count, default_data=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_unit, field_md, field, tstamp, fill_value) +!> Write a 1d field to an output file. +subroutine write_field_1d(io_unit, field_md, field, tstamp) integer, intent(in) :: io_unit !< File I/O unit handle type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(inout) :: field !< Field to write + 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 - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine MOM_write_field_1d + call mpp_write(io_unit, field_md, field, tstamp=tstamp) +end subroutine write_field_1d -!> Write a 0d field to an output file -subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) +!> Write a 0d field to an output file. +subroutine write_field_0d(io_unit, field_md, field, tstamp) integer, intent(in) :: io_unit !< File I/O unit handle type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, intent(inout) :: field !< Field to write + real, intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - call write_field(io_unit, field_md, field, tstamp=tstamp) -end subroutine MOM_write_field_0d + call mpp_write(io_unit, field_md, field, tstamp=tstamp) +end subroutine write_field_0d + +subroutine MOM_write_axis(io_unit, axis) + integer, intent(in) :: io_unit !< File I/O unit handle + type(axistype), intent(in) :: axis !< An axis type variable with information to write + + call mpp_write(io_unit, axis) + +end subroutine MOM_write_axis end module MOM_io_infra From d1f35b3ea2d71d00339c2d5d10197e1ec2d15513 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 16 Jan 2021 08:02:26 -0500 Subject: [PATCH 140/212] +Separated MOM_interp_infra from MOM_interpolate Created the infrastructure wrapper module MOM_interp_infra.F90, while retaining MOM_interpolate.F90 to do the rotation of the arrays and to provide the public interfaces for use in the rest of the MOM6 code. As a part of this, time_interp_extern was renamed back to time_interp_external (now that the pgi compiler bugs no longer interfere), which is reflected in changes in other modules. All answers are bitwise identical, but there is a reversion of publicly visible interface name. --- .../MOM_surface_forcing_gfdl.F90 | 6 +- src/core/MOM_open_boundary.F90 | 6 +- src/framework/MOM_horizontal_regridding.F90 | 6 +- src/framework/MOM_interp_infra.F90 | 100 ++++++++++++++++++ src/framework/MOM_interpolate.F90 | 67 ++++-------- src/ice_shelf/MOM_ice_shelf.F90 | 6 +- .../vertical/MOM_diabatic_aux.F90 | 5 +- 7 files changed, 132 insertions(+), 64 deletions(-) create mode 100644 src/framework/MOM_interp_infra.F90 diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 67f6643a42..44e1fb14d2 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -21,7 +21,7 @@ module MOM_surface_forcing_gfdl use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : init_external_field, time_interp_extern +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_restart, only : register_restart_field, restart_init, MOM_restart_CS @@ -349,7 +349,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_extern(CS%id_srestore, Time, data_restore) + call time_interp_external(CS%id_srestore, Time, data_restore) ! 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 @@ -406,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_extern(CS%id_trestore, Time, data_restore) + call time_interp_external(CS%id_trestore, Time, data_restore) 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) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c06cbfeb11..71e2aeeb5b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -24,7 +24,7 @@ module MOM_open_boundary 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_extern, time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init 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 @@ -3908,7 +3908,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tmp_buffer_in => tmp_buffer endif - call time_interp_extern(segment%field(m)%fid,Time, tmp_buffer_in) + call time_interp_external(segment%field(m)%fid,Time, tmp_buffer_in) ! NOTE: Rotation of face-points require that we skip the final value if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. @@ -3975,7 +3975,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! no dz for tidal variables if (segment%field(m)%nk_src > 1 .and.& (index(segment%field(m)%name, 'phase') .le. 0 .and. index(segment%field(m)%name, 'amp') .le. 0)) then - call time_interp_extern(segment%field(m)%fid_dz,Time, tmp_buffer_in) + call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. if (segment%is_E_or_W & diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index b1eb005f14..d63e2d743a 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -11,7 +11,7 @@ module MOM_horizontal_regridding use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_extern, get_external_field_info, horiz_interp_init +use MOM_interpolate, only : time_interp_external, get_external_field_info, horiz_interp_init use MOM_interpolate, only : horiz_interp_new, horiz_interp, horiz_interp_type use MOM_io_infra, only : axistype, get_axis_data use MOM_time_manager, only : time_type @@ -768,7 +768,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (.not.spongeDataOngrid) then if (is_root_pe()) & - call time_interp_extern(fms_id, Time, data_in, verbose=.true., turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=.true., 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 @@ -885,7 +885,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_extern(fms_id, Time, data_in, verbose=.true., turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/framework/MOM_interp_infra.F90 b/src/framework/MOM_interp_infra.F90 new file mode 100644 index 0000000000..e062edcaac --- /dev/null +++ b/src/framework/MOM_interp_infra.F90 @@ -0,0 +1,100 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interp_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_io_infra, only : axistype +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 + +implicit none ; private + +public :: time_interp_extern, init_external_field, time_interp_external_init +public :: get_external_field_info +public :: horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_extern + module procedure time_interp_extern_0d + module procedure time_interp_extern_2d + module procedure time_interp_extern_3d +end interface time_interp_extern + +contains + +!> 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 + + if (present(size)) then + size(1:4) = get_external_field_size(field_id) + endif + + if (present(axes)) then + axes(1:4) = get_external_field_axes(field_id) + endif + + if (present(missing)) then + missing = get_external_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() + 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) +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() + 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 + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + 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, & + 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() + 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 + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + 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, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_3d + +end module MOM_interp_infra diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 2ded435165..0e313ed478 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -1,59 +1,30 @@ -!> This module wraps the FMS temporal and spatial interpolation routines +!> This module provides added functionality to the FMS temporal and spatial interpolation routines module MOM_interpolate ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL +use MOM_interp_infra, only : time_interp_extern, init_external_field, time_interp_external_init +use MOM_interp_infra, only : get_external_field_info +use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new use MOM_io_infra, only : axistype 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_fms=>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 implicit none ; private -public :: time_interp_extern, init_external_field, time_interp_external_init -public :: get_external_field_info +public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info public :: horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new !> Read a field based on model time, and rotate to the model domain. -! This inerface does not share the name time_interp_external with the module it primarily -! wraps because of errors (perhaps a bug) that arise with the PGI 19.10.0 compiler. -interface time_interp_extern +interface time_interp_external module procedure time_interp_external_0d module procedure time_interp_external_2d module procedure time_interp_external_3d -end interface time_interp_extern +end interface time_interp_external contains -!> 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 - - if (present(size)) then - size(1:4) = get_external_field_size(field_id) - endif - - if (present(axes)) then - axes(1:4) = get_external_field_axes(field_id) - endif - - if (present(missing)) then - missing = get_external_field_missing(field_id) - endif - -end subroutine get_external_field_info - - !> Read a scalar field based on model time. subroutine time_interp_external_0d(field_id, time, data_in, verbose) integer, intent(in) :: field_id !< The integer index of the external field returned @@ -62,7 +33,7 @@ subroutine time_interp_external_0d(field_id, time, data_in, verbose) real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - call time_interp_external_fms(field_id, time, data_in, verbose=verbose) + call time_interp_extern(field_id, time, data_in, verbose=verbose) end subroutine time_interp_external_0d !> Read a 2d field from an external based on model time, potentially including horizontal @@ -87,16 +58,15 @@ subroutine time_interp_external_2d(field_id, time, data_in, interp, verbose, hor if (present(mask_out)) & call MOM_error(FATAL, "Rotation of masked output not yet support") - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_external_fms(field_id, time, data_in, interp=interp, & - verbose=verbose, horz_interp=horz_interp) + call time_interp_extern(field_id, 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_external_fms(field_id, time, data_pre_rot, interp=interp, & - verbose=verbose, horz_interp=horz_interp) + call time_interp_extern(field_id, 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) endif @@ -125,16 +95,15 @@ subroutine time_interp_external_3d(field_id, time, data_in, interp, & if (present(mask_out)) & call MOM_error(FATAL, "Rotation of masked output not yet support") - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_external_fms(field_id, time, data_in, interp=interp, & - verbose=verbose, horz_interp=horz_interp) + call time_interp_extern(field_id, 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_external_fms(field_id, time, data_pre_rot, interp=interp, & - verbose=verbose, horz_interp=horz_interp) + call time_interp_extern(field_id, 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) endif diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 050ac058e8..ac951602fc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -57,7 +57,7 @@ module MOM_ice_shelf use MOM_coms, only : reproducing_sum 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_extern, time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init implicit none ; private @@ -1084,7 +1084,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_extern(CS%id_read_mass, Time0, last_mass_shelf) + call time_interp_external(CS%id_read_mass, 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 @@ -1984,7 +1984,7 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) allocate(tmp2d(is:ie,js:je)) ; tmp2d(:,:) = 0.0 endif - call time_interp_extern(CS%id_read_mass, Time, tmp2d) + call time_interp_external(CS%id_read_mass, Time, tmp2d) call rotate_array(tmp2d, CS%turns, ISS%mass_shelf) deallocate(tmp2d) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 8ba9dd959a..e9c5e847e1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -15,8 +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_interpolate, only : init_external_field, time_interp_extern -use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init 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 @@ -621,7 +620,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity_CSp, tracer_ 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_extern(CS%sbc_chl, CS%Time, chl_2d) + call time_interp_external(CS%sbc_chl, CS%Time, chl_2d) do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& From cc5789494fd10491ac99ca4a39dcbe4a800c1753 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 16 Jan 2021 12:41:06 -0500 Subject: [PATCH 141/212] +Simplified MOM_domain_infra dependencies Eliminated the dependency of MOM_domain_infra.F90 on MOM_array_transform.F90 by explicitly rotatign the maskmap if necessary. Added the new optional argument coarsen to get_domain_extent and made three other existing arguments optional, which makes the routine get_domain_extent_dsamp2 redundant, so it was removed. Also store the domain name in the MOM_domain type, and use this as the default when cloning one domain type with another. --- src/core/MOM_grid.F90 | 8 +- src/framework/MOM_domain_infra.F90 | 162 +++++++++++++++-------------- src/framework/MOM_domains.F90 | 4 +- 3 files changed, 89 insertions(+), 85 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 9ca98adf71..60219c1c68 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2, deallocate_MOM_domain +use MOM_domains, only : get_global_shape, deallocate_MOM_domain use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_unit_scaling, only : unit_scale_type @@ -363,9 +363,9 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") - call get_domain_extent_dsamp2(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec,& - G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed,& - G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) + call get_domain_extent(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, & + G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed, & + G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg, coarsen=2) ! Set array sizes for fields that are discretized at tracer cell boundaries. G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 65cb93d151..cc465e3f12 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -3,10 +3,9 @@ module MOM_domain_infra ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_array_transform, only : rotate_array -use MOM_coms_infra, only : PE_here, root_PE, num_PEs -use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end -use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL +use MOM_coms_infra, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain @@ -34,7 +33,7 @@ module MOM_domain_infra public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain public :: create_MOM_domain, clone_MOM_domain, get_domain_components public :: deallocate_MOM_domain, deallocate_domain_contents -public :: get_domain_extent, get_domain_extent_dsamp2 +public :: get_domain_extent public :: pass_var, pass_vector, fill_symmetric_edges, global_field_sum public :: pass_var_start, pass_var_complete public :: pass_vector_start, pass_vector_complete @@ -105,6 +104,7 @@ module MOM_domain_infra !> The MOM_domain_type contains information about the domain decomposition. type, public :: MOM_domain_type + character(len=64) :: name !< The name of this domain type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos @@ -113,8 +113,7 @@ module MOM_domain_infra integer :: njglobal !< The total horizontal j-domain size. integer :: nihalo !< The i-halo size in memory. integer :: njhalo !< The j-halo size in memory. - logical :: symmetric !< True if symmetric memory is used with - !! this domain. + logical :: symmetric !< True if symmetric memory is used with this domain. logical :: nonblocking_updates !< If true, non-blocking halo updates are !! allowed. The default is .false. (for now). logical :: thin_halo_updates !< If true, optional arguments may be used to @@ -1175,7 +1174,7 @@ end subroutine complete_group_pass !> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information !! provided in arguments. subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & - domain_name, mask_table, symmetric, thin_halos, nonblocking) + domain_name, mask_table, symmetric, thin_halos, nonblocking) type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in !! the i- and j-directions @@ -1199,7 +1198,6 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. integer :: xhalo_d2, yhalo_d2 character(len=200) :: mesg ! A string for use in error messages - character(len=64) :: dom_name ! The domain name logical :: mask_table_exists ! Mask_table is present and the file it points to exists if (.not.associated(MOM_dom)) then @@ -1208,7 +1206,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l allocate(MOM_dom%mpp_domain_d2) endif - dom_name = "MOM" ; if (present(domain_name)) dom_name = trim(domain_name) + MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name) X_FLAGS = 0 ; Y_FLAGS = 0 if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN @@ -1262,7 +1260,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l mask_table_exists = file_exist(mask_table) if (mask_table_exists) then allocate(MOM_dom%maskmap(layout(1), layout(2))) - call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) + call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) endif else mask_table_exists = .false. @@ -1270,15 +1268,15 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l if (mask_table_exists) then call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name, & + symmetry=MOM_dom%symmetric, name=MOM_dom%name, & maskmap=MOM_dom%maskmap ) else call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name) + symmetry = MOM_dom%symmetric, name=MOM_dom%name) endif if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. (layout(1)*layout(2) > 1)) then @@ -1293,15 +1291,15 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l global_indices(1:4) = (/ 1, int(MOM_dom%niglobal/2), 1, int(MOM_dom%njglobal/2) /) if (mask_table_exists) then call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=X_FLAGS, yflags=Y_FLAGS, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry = MOM_dom%symmetric, name=trim("MOMc"), & + symmetry=MOM_dom%symmetric, name=trim("MOMc"), & maskmap=MOM_dom%maskmap ) else call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=X_FLAGS, yflags=Y_FLAGS, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry = MOM_dom%symmetric, name=trim("MOMc")) + symmetry=MOM_dom%symmetric, name=trim("MOMc")) endif if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. & @@ -1399,8 +1397,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) +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, turns) type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be !! allocated if it is unassociated, and will have data @@ -1416,17 +1413,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & !! whether the new domain is symmetric, regardless of !! whether the macro SYMMETRIC_MEMORY_ is defined. character(len=*), & - optional, intent(in) :: domain_name !< A name for the new domain, "MOM" - !! if missing. + optional, intent(in) :: domain_name !< A name for the new domain, copied + !! from MD_in if missing. integer, optional, intent(in) :: turns !< Number of quarter turns integer :: global_indices(4) logical :: mask_table_exists - character(len=64) :: dom_name - integer :: qturns + integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. + integer :: i, j, nl1, nl2 qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) qturns = modulo(turns, 4) if (.not.associated(MOM_dom)) then allocate(MOM_dom) @@ -1461,11 +1458,26 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & if (associated(MD_in%maskmap)) then mask_table_exists = .true. allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) - if (qturns /= 0) then - call rotate_array(MD_in%maskmap(:,:), qturns, MOM_dom%maskmap(:,:)) - else - MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) - endif + + nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) + select case (modulo(qturns, 4)) + case (0) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) + enddo ; enddo + case (1) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i) + enddo ; enddo + case (2) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j) + enddo ; enddo + case (3) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i) + enddo ; enddo + end select else mask_table_exists = .false. endif @@ -1486,14 +1498,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif - dom_name = "MOM" - if (present(domain_name)) dom_name = trim(domain_name) + if (present(domain_name)) then + MOM_dom%name = trim(domain_name) + else + MOM_dom%name = MD_in%name + endif if (mask_table_exists) then call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=dom_name, & + symmetry=MOM_dom%symmetric, name=MOM_dom%name, & maskmap=MOM_dom%maskmap) global_indices(2) = global_indices(2) / 2 @@ -1502,13 +1517,13 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & MOM_dom%mpp_domain_d2, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=dom_name, & + symmetry=MOM_dom%symmetric, name=MOM_dom%name, & maskmap=MOM_dom%maskmap) else call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=dom_name) + symmetry=MOM_dom%symmetric, name=MOM_dom%name) global_indices(2) = global_indices(2) / 2 global_indices(4) = global_indices(4) / 2 @@ -1516,7 +1531,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & MOM_dom%mpp_domain_d2, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=dom_name) + symmetry=MOM_dom%symmetric, name=MOM_dom%name) endif if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & @@ -1580,7 +1595,7 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & if (present(symmetric)) then ; symmetric_dom = symmetric ; endif - dom_name = "MOM" + dom_name = MD_in%name if (present(domain_name)) dom_name = trim(domain_name) global_indices(1) = 1 ; global_indices(2) = niglobal @@ -1608,7 +1623,7 @@ end subroutine clone_MD_to_d2D !> Returns various data that has been stored in a MOM_domain_type subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & isg, ieg, jsg, jeg, idg_offset, jdg_offset, & - symmetric, local_indexing, index_offset) + symmetric, local_indexing, index_offset, coarsen) type(MOM_domain_type), & intent(in) :: Domain !< The MOM domain from which to extract information integer, intent(out) :: isc !< The start i-index of the computational domain @@ -1623,75 +1638,64 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & integer, intent(out) :: ieg !< The end i-index of the global domain integer, intent(out) :: jsg !< The start j-index of the global domain integer, intent(out) :: jeg !< The end j-index of the global domain - integer, intent(out) :: idg_offset !< The offset between the corresponding global and + integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and !! data i-index spaces. - integer, intent(out) :: jdg_offset !< The offset between the corresponding global and + integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and !! data j-index spaces. - logical, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, !! as in most MOM6 code. integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This !! can be useful for some types of debugging with !! dynamic memory allocation. + integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. + !! The default is 1, for no coarsening. + ! Local variables - integer :: ind_off + integer :: ind_off, idg_off, jdg_off, coarsen_lev logical :: local local = .true. ; if (present(local_indexing)) local = local_indexing ind_off = 0 ; if (present(index_offset)) ind_off = index_offset - call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain, isg, ieg, jsg, jeg) + coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen + + if (coarsen_lev == 1) then + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain, isg, ieg, jsg, jeg) + elseif (coarsen_lev == 2) then + if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & + "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain_d2, isg, ieg, jsg, jeg) + else + call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") + endif - ! This code institutes the MOM convention that local array indices start at 1. if (local) then - idg_offset = isd-1 ; jdg_offset = jsd-1 + ! This code institutes the MOM convention that local array indices start at 1. + idg_off = isd-1 ; jdg_off = jsd-1 isc = isc-isd+1 ; iec = iec-isd+1 ; jsc = jsc-jsd+1 ; jec = jec-jsd+1 ied = ied-isd+1 ; jed = jed-jsd+1 isd = 1 ; jsd = 1 else - idg_offset = 0 ; jdg_offset = 0 + idg_off = 0 ; jdg_off = 0 endif if (ind_off /= 0) then - idg_offset = idg_offset + ind_off ; jdg_offset = jdg_offset + ind_off + idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off isc = isc + ind_off ; iec = iec + ind_off jsc = jsc + ind_off ; jec = jec + ind_off isd = isd + ind_off ; ied = ied + ind_off jsd = jsd + ind_off ; jed = jed + ind_off endif - symmetric = Domain%symmetric + if (present(idg_offset)) idg_offset = idg_off + if (present(jdg_offset)) jdg_offset = jdg_off + if (present(symmetric)) symmetric = Domain%symmetric end subroutine get_domain_extent -subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& - isd_d2, ied_d2, jsd_d2, jed_d2,& - isg_d2, ieg_d2, jsg_d2, jeg_d2) - type(MOM_domain_type), & - intent(in) :: Domain !< The MOM domain from which to extract information - integer, intent(out) :: isc_d2 !< The start i-index of the computational domain - integer, intent(out) :: iec_d2 !< The end i-index of the computational domain - integer, intent(out) :: jsc_d2 !< The start j-index of the computational domain - integer, intent(out) :: jec_d2 !< The end j-index of the computational domain - integer, intent(out) :: isd_d2 !< The start i-index of the data domain - integer, intent(out) :: ied_d2 !< The end i-index of the data domain - integer, intent(out) :: jsd_d2 !< The start j-index of the data domain - integer, intent(out) :: jed_d2 !< The end j-index of the data domain - integer, intent(out) :: isg_d2 !< The start i-index of the global domain - integer, intent(out) :: ieg_d2 !< The end i-index of the global domain - integer, intent(out) :: jsg_d2 !< The start j-index of the global domain - integer, intent(out) :: jeg_d2 !< The end j-index of the global domain - - call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) - call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) - call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) - ! This code institutes the MOM convention that local array indices start at 1. - isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 - jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 - ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 - isd_d2 = 1 ; jsd_d2 = 1 -end subroutine get_domain_extent_dsamp2 - !> Return the (potentially symmetric) computational domain i-bounds for an array !! passed without index specifications (i.e. indices start at 1) based on an array size. subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 032b479d3d..d25e7831f8 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -7,7 +7,7 @@ module MOM_domains use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, create_MOM_domain -use MOM_domain_infra, only : get_domain_extent, get_domain_extent_dsamp2 +use MOM_domain_infra, only : get_domain_extent use MOM_domain_infra, only : clone_MOM_domain, get_domain_components use MOM_domain_infra, only : deallocate_MOM_domain, deallocate_domain_contents use MOM_domain_infra, only : MOM_define_domain, MOM_define_layout, MOM_define_io_domain @@ -31,7 +31,7 @@ module MOM_domains public :: MOM_domains_init, MOM_domain_type, MOM_infra_init, MOM_infra_end public :: domain2D, domain1D -public :: get_domain_extent, get_domain_extent_dsamp2 +public :: get_domain_extent public :: create_MOM_domain, clone_MOM_domain, get_domain_components public :: deallocate_MOM_domain, deallocate_domain_contents public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain From 9f6884f17ac0e82363f5ec19f252b3b910bac95b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 17 Jan 2021 09:25:10 -0500 Subject: [PATCH 142/212] +Renamed refine optional arguments to coarsen Renamed the recently added refine optional arguments to diag_axis_init to coarsen to better reflect what it does. All answers are bitwise identical. --- src/framework/MOM_diag_manager.F90 | 18 +++++++++--------- src/framework/MOM_diag_mediator.F90 | 12 ++++++------ 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/framework/MOM_diag_manager.F90 b/src/framework/MOM_diag_manager.F90 index 851001bc34..6519ffadb6 100644 --- a/src/framework/MOM_diag_manager.F90 +++ b/src/framework/MOM_diag_manager.F90 @@ -99,7 +99,7 @@ end function register_diag_field_scalar_fms !> diag_axis_init stores up the information for an axis that can be used for diagnostics and !! returns an integer hadle for this axis. integer function diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & - direction, edges, set_name, refine, null_axis) + direction, edges, set_name, coarsen, null_axis) character(len=*), intent(in) :: name !< The name of this axis real, dimension(:), intent(in) :: data !< The array of coordinate values character(len=*), intent(in) :: units !< The units for the axis data @@ -118,12 +118,12 @@ integer function diag_axis_init(name, data, units, cart_name, long_name, MOM_dom !! describes the edges of this axis character(len=*), & optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: refine !< An optional degree of refinement for the grid, 1 + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 !! by default. logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis !! id for use with scalars. - integer :: refinement ! The degree of grid refinement + integer :: coarsening ! The degree of grid coarsening if (present(null_axis)) then ; if (null_axis) then ! Return the special null axis id for scalars @@ -132,21 +132,21 @@ integer function diag_axis_init(name, data, units, cart_name, long_name, MOM_dom endif ; endif if (present(MOM_domain)) then - refinement = 1 ; if (present(refine)) refinement = refine - if (refinement == 1) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) then diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & domain2=MOM_domain%mpp_domain, domain_position=position) - elseif (refinement == 2) then + elseif (coarsening == 2) then diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & domain2=MOM_domain%mpp_domain_d2, domain_position=position) else - call MOM_error(FATAL, "diag_axis_init called with an invalid value of refine.") + call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") endif else - if (present(refine)) then ; if (refine /= 1) then - call MOM_error(FATAL, "diag_axis_init does not support grid refinement without a MOM_domain.") + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") endif ; endif diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 7a462503ea..108bd389e6 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -601,9 +601,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, refine=2) + 'q point nominal longitude', G%Domain, coarsen=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', G%Domain, refine=2) + 'q point nominal latitude', G%Domain, coarsen=2) deallocate(gridLonB_dsamp,gridLatB_dsamp) else allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) @@ -611,9 +611,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, refine=2) + 'q point nominal longitude', G%Domain, coarsen=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', G%Domain, refine=2) + 'q point nominal latitude', G%Domain, coarsen=2) deallocate(gridLonB_dsamp,gridLatB_dsamp) endif @@ -622,9 +622,9 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & - 'h point nominal longitude', G%Domain, refine=2) + 'h point nominal longitude', G%Domain, coarsen=2) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & - 'h point nominal latitude', G%Domain, refine=2) + 'h point nominal latitude', G%Domain, coarsen=2) deallocate(gridLonT_dsamp,gridLatT_dsamp) From 9a53c5e0ece8cc407513149e99a5f38a5a75f26a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 17 Jan 2021 09:25:46 -0500 Subject: [PATCH 143/212] +Removed the redundant routine read_axis_data Removed the routine read_axis_data, which performs a function that is already dealt with by MOM_read_data. It has been replaced with MOM_read_data in the one place where read_axis_data was actually being called. All answers are bitwise identical, but a public interface was deleted. --- src/framework/MOM_io.F90 | 4 +- src/framework/MOM_io_infra.F90 | 52 +++---------------- src/ice_shelf/user_shelf_init.F90 | 14 +++-- .../MOM_coord_initialization.F90 | 34 ++++++------ 4 files changed, 31 insertions(+), 73 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 8060b7b233..2a547dbdd1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -14,7 +14,7 @@ module MOM_io use MOM_io_infra, only : file_exists, get_file_info, get_file_atts, get_file_fields use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, field_exists use MOM_io_infra, only : flush_file, get_filename_appendix, get_ensemble_id -use MOM_io_infra, only : get_file_times, axistype, get_axis_data, read_axis_data +use MOM_io_infra, only : get_file_times, axistype, get_axis_data use MOM_io_infra, only : write_field, write_metadata, write_version_number use MOM_io_infra, only : open_namelist_file, check_nml_error, io_infra_init, io_infra_end use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE @@ -36,7 +36,7 @@ module MOM_io ! The following are simple pass throughs of routines from MOM_io_infra or other modules public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields -public :: get_file_times, open_file, read_axis_data, get_axis_data +public :: get_file_times, open_file, get_axis_data public :: MOM_read_data, MOM_read_vector, read_data, read_field_chksum public :: slasher, write_field, write_version_number public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index f699290dc3..a854cd6d2a 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -27,11 +27,12 @@ module MOM_io_infra implicit none ; private -! These interfaces are actually implemented in this file. -public :: MOM_read_data, MOM_read_vector, write_field, read_axis_data +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: MOM_read_data, MOM_read_vector, write_field, open_file public :: file_exists, field_exists, read_field_chksum -! The following are simple pass throughs of routines from other modules. -public :: open_file, close_file, field_size, fieldtype, get_filename_appendix +! The following are simple pass throughs of routines from other modules. They need +! to have explicit interfaces added to this file. +public :: close_file, field_size, fieldtype, get_filename_appendix public :: flush_file, get_file_info, get_file_atts, get_file_fields, get_field_atts public :: get_file_times, read_data, axistype, get_axis_data public :: write_metadata, write_version_number, get_ensemble_id @@ -74,46 +75,8 @@ module MOM_io_infra contains -!> Read the data associated with a named axis in a file -subroutine read_axis_data(filename, axis_name, var) - character(len=*), intent(in) :: filename !< Name of the file to read - character(len=*), intent(in) :: axis_name !< Name of the axis to read - real, dimension(:), intent(out) :: var !< The axis location data - - integer :: i, len, unit, ndim, nvar, natt, ntime - logical :: axis_found - type(axistype), allocatable :: axes(:) - type(axistype) :: time_axis - character(len=32) :: name, units - - call open_file(unit, trim(filename), action=READONLY_FILE, form=NETCDF_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) - -!Find the number of variables (nvar) in this file - call get_file_info(unit, ndim, nvar, natt, ntime) -! ------------------------------------------------------------------- -! Allocate space for the number of axes in the data file. -! ------------------------------------------------------------------- - allocate(axes(ndim)) - call mpp_get_axes(unit, axes, time_axis) - - axis_found = .false. - do i = 1, ndim - call get_file_atts(axes(i), name=name, len=len, units=units) - if (name == axis_name) then - axis_found = .true. - call get_axis_data(axes(i), var) - exit - endif - enddo - - if (.not.axis_found) call MOM_error(FATAL, "MOM_io read_axis_data: "//& - "Unable to find axis "//trim(axis_name)//" in file "//trim(filename)) - - deallocate(axes) - -end subroutine read_axis_data - +!> Reads the checksum value for a field that was recorded in a file, along with a flag indicating +!! whether the file contained a valid checksum for this field. subroutine read_field_chksum(field, chksum, valid_chksum) type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. integer(kind=8), intent(out) :: chksum !< The checksum for the field. @@ -131,7 +94,6 @@ subroutine read_field_chksum(field, chksum, valid_chksum) endif end subroutine read_field_chksum - !> Returns true if the named file or its domain-decomposed variant exists. function MOM_file_exists(filename, MOM_Domain) character(len=*), intent(in) :: filename !< The name of the file being inquired about diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 122758f3cc..c9370ead8f 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -4,15 +4,13 @@ module user_shelf_init ! This file is part of MOM6. See LICENSE.md for the license. -! use MOM_domains, only : sum_across_PEs use MOM_error_handler, only : MOM_mesg, MOM_error, 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_time_manager, only : time_type, set_time, time_type_to_real -use MOM_unit_scaling, only : unit_scale_type -! use MOM_io, only : close_file, fieldtype, file_exists -! use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE -! use MOM_io, only : write_field, slasher +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +! use MOM_io, only : file_exists, read_data, slasher + implicit none ; private #include diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index c1ec788836..23d279b65a 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -3,21 +3,19 @@ module MOM_coord_initialization ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : chksum -use MOM_EOS, only : calculate_density, EOS_type -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 -use MOM_file_parser, only : log_version -use MOM_io, only : close_file, create_file, fieldtype, file_exists -use MOM_io, only : open_file, MOM_read_data, read_axis_data, SINGLE_FILE, MULTIPLE -use MOM_io, only : slasher, vardesc, write_field, var_desc -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, setVerticalGridAxes -use user_initialization, only : user_set_coord -use BFB_initialization, only : BFB_set_coord +use MOM_debugging, only : chksum +use MOM_EOS, only : calculate_density, EOS_type +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 : MOM_read_data, close_file, create_file, fieldtype, file_exists +use MOM_io, only : write_field, vardesc, var_desc, SINGLE_FILE, MULTIPLE +use MOM_string_functions, only : slasher, uppercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes +use user_initialization, only : user_set_coord +use BFB_initialization, only : BFB_set_coord use netcdf @@ -286,8 +284,8 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s filename = trim(slasher(inputdir))//trim(coord_file) call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) - call MOM_read_data(filename,"PTEMP",T0(:)) - call MOM_read_data(filename,"SALT",S0(:)) + call MOM_read_data(filename, "PTEMP", T0(:)) + call MOM_read_data(filename, "SALT", S0(:)) if (.not.file_exists(filename)) call MOM_error(FATAL, & " set_coord_from_TS_profile: Unable to open " //trim(filename)) @@ -420,7 +418,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) if (.not.file_exists(filename)) call MOM_error(FATAL, & " set_coord_from_file: Unable to open "//trim(filename)) - call read_axis_data(filename, coord_var, Rlay) + call MOM_read_data(filename, coord_var, Rlay) do k=1,nz ; Rlay(k) = US%kg_m3_to_R*Rlay(k) ; enddo g_prime(1) = g_fs do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo From 354d6d6406fc09f534e954c6ba42881a6116e725 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 18 Jan 2021 09:00:59 -0500 Subject: [PATCH 144/212] MOM_hor_visc: Revert tension/shear loop fusion The fusion of tension and shear strains yields a 1-2% speedup, but also breaks the style convention of capitalization of vertex points, and also evaluates the tension terms over a slightly larger domain, so it has been reverted. A note has been added to investigate this later. --- .../lateral/MOM_hor_visc.F90 | 25 ++++++++++++------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 06a6269dc5..003b134b2a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -528,21 +528,29 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! shearing strain advocated by Smagorinsky (1993) and discussed in ! Griffies and Hallberg (2000). - do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 - ! Calculate horizontal tension + ! NOTE: There is a ~1% speedup when the tension and shearing loops below + ! are fused (presumably due to shared access of Id[xy]C[uv]). However, + ! this breaks the center/vertex index case convention, and also evaluates + ! the dudx and dvdy terms beyond their valid bounds. + ! TODO: Explore methods for retaining both the syntax and speedup. + + ! Calculate horizontal tension + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 dudx(i,j) = CS%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) = CS%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) + enddo ; enddo - ! Components for the shearing strain + ! Components for the shearing strain + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 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%id_normstress > 0) then - do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 NoSt(i,j,k) = sh_xx(i,j) enddo ; enddo endif @@ -885,6 +893,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 if (CS%add_LES_viscosity) then if (CS%Smagorinsky_Kh) & @@ -1217,12 +1227,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! All viscosity contributions above are subject to resolution scaling + ! NOTE: The following do-block can be decomposed and vectorized after the + ! stack size has been reduced. do J=js-1,Jeq ; do I=is-1,Ieq - ! NOTE: The following do-block can be decomposed and vectorized, but - ! appears to cause slowdown on some machines. Evidence suggests that - ! this is caused by excessive spilling of stack variables. - ! TODO: Vectorize these loops after stack usage has been reduced.. - if (rescale_Kh) & Kh(i,j) = VarMix%Res_fn_q(i,j) * Kh(i,j) From 22eab1af7b3adb5b8f469a9081d59d241b75c90c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Jan 2021 20:35:30 -0500 Subject: [PATCH 145/212] +Refined the MOM_domain_infra code Added the new optional arguments refine and extra_halo to clone_MD_to_MD, and added calls to ensure that the cloned domain uses the same decomposition as its parent domain. Also added the new optional arguments xextent, yextent and coarsen to clone_MD_to_d2D, while also modifying the code to ensure proper inheritance of the symmetry of the parent domain, as described in the comments. Also use calls to clone_MD_to_d2D to create the domain2D elements of the MOM_domain_types, including the coarsened domains, reducing code duplication. All answers are bitwise identical, but there are new optional arguments to some publicly visible routines. --- src/framework/MOM_domain_infra.F90 | 191 +++++++++++++---------------- 1 file changed, 86 insertions(+), 105 deletions(-) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index cc465e3f12..3334e8b855 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -1254,8 +1254,6 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l endif endif - global_indices(1:4) = (/ 1, MOM_dom%niglobal, 1, MOM_dom%njglobal /) - if (present(mask_table)) then mask_table_exists = file_exist(mask_table) if (mask_table_exists) then @@ -1266,51 +1264,18 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l mask_table_exists = .false. endif - if (mask_table_exists) then - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=MOM_dom%name, & - maskmap=MOM_dom%maskmap ) - else - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=MOM_dom%name) - endif - - if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) - endif + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain) !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 - xhalo_d2 = int(MOM_dom%nihalo/2) - yhalo_d2 = int(MOM_dom%njhalo/2) - global_indices(1:4) = (/ 1, int(MOM_dom%niglobal/2), 1, int(MOM_dom%njglobal/2) /) - if (mask_table_exists) then - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry=MOM_dom%symmetric, name=trim("MOMc"), & - maskmap=MOM_dom%maskmap ) - else - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=xhalo_d2, yhalo=yhalo_d2, & - symmetry=MOM_dom%symmetric, name=trim("MOMc")) - endif - - if ((MOM_dom%io_layout(1) > 0) .and. (MOM_dom%io_layout(2) > 0) .and. & - (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain_d2, MOM_dom%io_layout) - endif + ! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2) + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2) end subroutine create_MOM_domain !> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type -!! and all of its contents +!! and potentially all of its contents subroutine deallocate_MOM_domain(MOM_domain, cursory) type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated @@ -1397,7 +1362,8 @@ 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) +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & + turns, refine, extra_halo) type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be !! allocated if it is unassociated, and will have data @@ -1416,9 +1382,16 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain optional, intent(in) :: domain_name !< A name for the new domain, copied !! from MD_in if missing. integer, optional, intent(in) :: turns !< Number of quarter turns + 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 :: global_indices(4) logical :: mask_table_exists + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout. + ! 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 @@ -1439,6 +1412,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain if (modulo(qturns, 2) /= 0) then MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + call get_layout_extents(MD_in, exnj, exni) 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) @@ -1446,21 +1420,26 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain 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 + call get_layout_extents(MD_in, exni, exnj) 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(:) endif - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal + ! Ensure that the points per processor are the same on the source and densitation grids. + select case (qturns) + case (1) ; call invert(exni) + case (2) ; call invert(exni) ; call invert(exnj) + case (3) ; call invert(exnj) + end select if (associated(MD_in%maskmap)) then mask_table_exists = .true. allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) - select case (modulo(qturns, 4)) + select case (qturns) case (0) do j=1,nl2 ; do i=1,nl1 MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) @@ -1482,6 +1461,19 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain mask_table_exists = .false. endif + ! Optionally enhance the grid resolution. + if (present(refine)) then ; if (refine > 1) then + MOM_dom%niglobal = refine*MOM_dom%niglobal ; MOM_dom%njglobal = refine*MOM_dom%njglobal + MOM_dom%nihalo = refine*MOM_dom%nihalo ; MOM_dom%njhalo = refine*MOM_dom%njhalo + do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo + do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo + endif ; endif + + ! Optionally enhance the grid resolution. + if (present(extra_halo)) then ; if (extra_halo > 0) then + MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo + endif ; endif + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & "clone_MOM_domain can not have both halo_size and min_halo present.") @@ -1504,48 +1496,18 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain MOM_dom%name = MD_in%name endif - if (mask_table_exists) then - call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=MOM_dom%name, & - maskmap=MOM_dom%maskmap) - - global_indices(2) = global_indices(2) / 2 - global_indices(4) = global_indices(4) / 2 - call MOM_define_domain(global_indices, MOM_dom%layout, & - MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=MOM_dom%name, & - maskmap=MOM_dom%maskmap) - else - call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry=MOM_dom%symmetric, name=MOM_dom%name) - - global_indices(2) = global_indices(2) / 2 - global_indices(4) = global_indices(4) / 2 - call MOM_define_domain(global_indices, MOM_dom%layout, & - MOM_dom%mpp_domain_d2, & - xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & - xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & - symmetry=MOM_dom%symmetric, name=MOM_dom%name) - endif + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj) - if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & - (MOM_dom%layout(1)*MOM_dom%layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain, MOM_dom%io_layout) - endif + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2) end subroutine clone_MD_to_MD + !> clone_MD_to_d2D uses information from a MOM_domain_type to create a new !! domain2d type, while allowing some properties of the new type to differ from !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & - domain_name, turns) + domain_name, turns, xextent, yextent, coarsen) type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up integer, dimension(2), & @@ -1557,65 +1519,72 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & !! min_halo and halo_size can not both be present. logical, optional, intent(in) :: symmetric !< If present, this specifies !! whether the new domain is symmetric, regardless of - !! whether the macro SYMMETRIC_MEMORY_ is defined. + !! whether the macro SYMMETRIC_MEMORY_ is defined or + !! whether MD_in is symmetric. character(len=*), & optional, intent(in) :: domain_name !< A name for the new domain, "MOM" !! if missing. - integer, optional, intent(in) :: turns !< If true, swap X and Y axes + integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here. + integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid. + !! The default of 1 is for no coarsening. + integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the + !! tracer computational domain for division of the x-layout. + integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the + !! tracer computational domain for division of the y-layout. - integer :: global_indices(4), layout(2), io_layout(2) - integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo - logical :: symmetric_dom + integer :: global_indices(4) + integer :: nihalo, njhalo + logical :: symmetric_dom, do_coarsen character(len=64) :: dom_name if (present(turns)) & call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") -! Save the extra data for creating other domains of different resolution that overlay this domain - niglobal = MD_in%niglobal ; njglobal = MD_in%njglobal - nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo - - symmetric_dom = MD_in%symmetric - - X_FLAGS = MD_in%X_FLAGS ; Y_FLAGS = MD_in%Y_FLAGS - layout(:) = MD_in%layout(:) ; io_layout(:) = MD_in%io_layout(:) - if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & "clone_MOM_domain can not have both halo_size and min_halo present.") + do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif + + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + if (do_coarsen) then + nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen) + endif + if (present(min_halo)) then nihalo = max(nihalo, min_halo(1)) njhalo = max(njhalo, min_halo(2)) min_halo(1) = nihalo ; min_halo(2) = njhalo endif - if (present(halo_size)) then nihalo = halo_size ; njhalo = halo_size endif + symmetric_dom = MD_in%symmetric if (present(symmetric)) then ; symmetric_dom = symmetric ; endif dom_name = MD_in%name + if (do_coarsen) dom_name = trim(MD_in%name)//"c" if (present(domain_name)) dom_name = trim(domain_name) - global_indices(1) = 1 ; global_indices(2) = niglobal - global_indices(3) = 1 ; global_indices(4) = njglobal + global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /) + if (do_coarsen) then + global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /) + endif + if (associated(MD_in%maskmap)) then - call MOM_define_domain( global_indices, layout, mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=nihalo, yhalo=njhalo, & - symmetry = symmetric, name=dom_name, & + call MOM_define_domain( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & maskmap=MD_in%maskmap ) else - call MOM_define_domain( global_indices, layout, mpp_domain, & - xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=nihalo, yhalo=njhalo, & - symmetry = symmetric, name=dom_name) + call MOM_define_domain( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) endif - if ((io_layout(1) + io_layout(2) > 0) .and. & - (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(mpp_domain, io_layout) + if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & + (MD_in%layout(1)*MD_in%layout(2) > 1)) then + call MOM_define_io_domain(mpp_domain, MD_in%io_layout) endif end subroutine clone_MD_to_d2D @@ -1769,6 +1738,18 @@ subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) end subroutine get_simple_array_j_ind +!> Invert the contents of a 1-d array +subroutine invert(array) + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo +end subroutine invert + !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information From be5548040f3cafa9459a48980f1ee370b9141065 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Jan 2021 20:53:11 -0500 Subject: [PATCH 146/212] Use clone_MOM_domain to create mosaic supergrid Use a call to clone_MOM_domain (which resolves to clone_MD_to_MD) to allocate and populate the mosaic supergrid type in MOM_grid_initialize.F90. This greatly reduces the number of interfaces from MOM_domains.F90 that are actually used and need to be made public. --- src/initialization/MOM_grid_initialize.F90 | 52 ++++------------------ 1 file changed, 9 insertions(+), 43 deletions(-) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index eee168eefb..b5685745ac 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -7,8 +7,7 @@ module MOM_grid_initialize use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair use MOM_domains, only : To_North, To_South, To_East, To_West -use MOM_domains, only : MOM_define_domain, MOM_define_IO_domain, get_layout_extents -use MOM_domains, only : MOM_domain_type, deallocate_domain_contents +use MOM_domains, only : MOM_domain_type, clone_MOM_domain, deallocate_MOM_domain use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave @@ -185,13 +184,10 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) real :: m_to_L ! A unit conversion factor [L m-1 ~> nondim] character(len=200) :: filename, grid_file, inputdir character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" - integer :: err=0, ni, nj, global_indices(4) - type(MOM_domain_type) :: SGdom ! Supergrid domain + type(MOM_domain_type), pointer :: SGdom => NULL() ! Supergrid domain logical :: lon_bug ! If true use an older buggy answer in the tripolar longitude. - integer :: i, j, i2, j2 - integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout - integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout - integer :: start(4), nread(4) + integer :: i, j, i2, j2, ni, nj + integer :: start(4), nread(4) call callTree_enter("set_grid_metrics_from_mosaic(), MOM_grid_initialize.F90") @@ -217,39 +213,9 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) dxBu(:,:) = 0.0 ; dyBu(:,:) = 0.0 ; areaBu(:,:) = 0.0 ! - ni = 2*(G%iec-G%isc+1) ! i size of supergrid - nj = 2*(G%jec-G%jsc+1) ! j size of supergrid - - ! Define a domain for the supergrid (SGdom) - call get_layout_extents(G%domain, exni, exnj) - allocate(SGdom%mpp_domain) - SGdom%nihalo = 2*G%domain%nihalo+1 - SGdom%njhalo = 2*G%domain%njhalo+1 - SGdom%niglobal = 2*G%domain%niglobal - SGdom%njglobal = 2*G%domain%njglobal - SGdom%layout(:) = G%domain%layout(:) - SGdom%io_layout(:) = G%domain%io_layout(:) - global_indices(1) = 1+SGdom%nihalo - global_indices(2) = SGdom%niglobal+SGdom%nihalo - global_indices(3) = 1+SGdom%njhalo - global_indices(4) = SGdom%njglobal+SGdom%njhalo - exni(:) = 2*exni(:) ; exnj(:) = 2*exnj(:) - if (associated(G%domain%maskmap)) then - call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & - xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & - xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & - xextent=exni, yextent=exnj, & - symmetry=.true., name="MOM_MOSAIC", maskmap=G%domain%maskmap) - else - call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & - xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & - xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & - xextent=exni, yextent=exnj, & - symmetry=.true., name="MOM_MOSAIC") - endif - call MOM_define_IO_domain(SGdom%mpp_domain, SGdom%io_layout) - deallocate(exni, exnj) + call clone_MOM_domain(G%domain, SGdom, symmetric=.true., domain_name="MOM_MOSAIC", & + refine=2, extra_halo=1) ! Read X from the supergrid tmpZ(:,:) = 999. @@ -338,9 +304,9 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) (tmpT(i2,j2+1) + tmpT(i2+1,j2)) enddo ; enddo - ni=SGdom%niglobal - nj=SGdom%njglobal - call deallocate_domain_contents(SGdom) + ni = SGdom%niglobal + nj = SGdom%njglobal + call deallocate_MOM_domain(SGdom) call pass_vector(dyCu, dxCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dxCu, dyCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) From be4eace0b8fa26450beb414e6291ef019637b25e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 19 Jan 2021 06:58:35 -0500 Subject: [PATCH 147/212] +Eliminated unused MOM_domains interfaces As a result of reforms to MOM_grid_initialize in the previous commit, there are several interfaces from MOM_domains that are no longer used. The redundant interfaces were eliminated and the remaining interfaces regrouped with comments describing each group. This PR also folds deallocate_domain_contents into deallocate_domain. All answers are bitwise identical, but some unused public interfaces have been eliminated. --- src/framework/MOM_domain_infra.F90 | 42 ++++++++++------------------ src/framework/MOM_domains.F90 | 45 +++++++++++++++--------------- 2 files changed, 38 insertions(+), 49 deletions(-) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 3334e8b855..5096c8a78d 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -30,9 +30,9 @@ module MOM_domain_infra implicit none ; private -public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain +public :: MOM_define_domain, MOM_define_layout public :: create_MOM_domain, clone_MOM_domain, get_domain_components -public :: deallocate_MOM_domain, deallocate_domain_contents +public :: deallocate_MOM_domain public :: get_domain_extent public :: pass_var, pass_vector, fill_symmetric_edges, global_field_sum public :: pass_var_start, pass_var_complete @@ -42,7 +42,7 @@ module MOM_domain_infra public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass -public :: compute_block_extent, get_global_shape, get_layout_extents +public :: compute_block_extent, get_global_shape public :: MOM_thread_affinity_set, set_MOM_thread_affinity public :: get_simple_array_i_ind, get_simple_array_j_ind public :: domain2D, domain1D @@ -1280,36 +1280,24 @@ subroutine deallocate_MOM_domain(MOM_domain, cursory) type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated !! with the underlying infrastructure - - if (associated(MOM_domain)) then - call deallocate_domain_contents(MOM_domain, cursory) - deallocate(MOM_domain) - endif - -end subroutine deallocate_MOM_domain - -!> deallocate_domain_contents deallocates memory associated with pointers -!! inside of a MOM_domain_type. -subroutine deallocate_domain_contents(MOM_domain, cursory) - type(MOM_domain_type), intent(inout) :: MOM_domain !< A MOM_domain_type whose contents will be deallocated - logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated - !! with the underlying infrastructure - logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure invasive = .true. ; if (present(cursory)) invasive = .not.cursory - if (associated(MOM_domain%mpp_domain)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) - deallocate(MOM_domain%mpp_domain) - endif - if (associated(MOM_domain%mpp_domain_d2)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) - deallocate(MOM_domain%mpp_domain_d2) + if (associated(MOM_domain)) then + if (associated(MOM_domain%mpp_domain)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) + deallocate(MOM_domain%mpp_domain) + endif + if (associated(MOM_domain%mpp_domain_d2)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) + deallocate(MOM_domain%mpp_domain_d2) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + deallocate(MOM_domain) endif - if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) -end subroutine deallocate_domain_contents +end subroutine deallocate_MOM_domain !> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. function MOM_thread_affinity_set() diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index d25e7831f8..e03401aa83 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,21 +3,19 @@ module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs -use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end -use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, create_MOM_domain -use MOM_domain_infra, only : get_domain_extent -use MOM_domain_infra, only : clone_MOM_domain, get_domain_components -use MOM_domain_infra, only : deallocate_MOM_domain, deallocate_domain_contents -use MOM_domain_infra, only : MOM_define_domain, MOM_define_layout, MOM_define_io_domain -use MOM_domain_infra, only : pass_var, pass_vector -use MOM_domain_infra, only : pass_var_start, pass_var_complete, fill_symmetric_edges +use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D +use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +use MOM_domain_infra, only : MOM_define_domain, MOM_define_layout +use MOM_domain_infra, only : get_domain_extent, get_domain_components +use MOM_domain_infra, only : compute_block_extent, get_global_shape +use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum +use MOM_domain_infra, only : pass_var_start, pass_var_complete use MOM_domain_infra, only : pass_vector_start, pass_vector_complete use MOM_domain_infra, only : create_group_pass, do_group_pass, group_pass_type use MOM_domain_infra, only : start_group_pass, complete_group_pass -use MOM_domain_infra, only : global_field_sum -use MOM_domain_infra, only : compute_block_extent, get_global_shape, get_layout_extents use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM 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 @@ -29,19 +27,22 @@ module MOM_domains implicit none ; private -public :: MOM_domains_init, MOM_domain_type, MOM_infra_init, MOM_infra_end -public :: domain2D, domain1D -public :: get_domain_extent -public :: create_MOM_domain, clone_MOM_domain, get_domain_components -public :: deallocate_MOM_domain, deallocate_domain_contents -public :: MOM_define_domain, MOM_define_layout, MOM_define_io_domain -public :: pass_var, pass_vector, PE_here, root_PE, num_PEs -public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast -public :: pass_vector_start, pass_vector_complete +public :: MOM_infra_init, MOM_infra_end +! Domain types and creation and destruction routines +public :: MOM_domain_type, domain2D, domain1D +public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +! Domain query routines +public :: get_domain_extent, get_domain_components, compute_block_extent, get_global_shape +public :: PE_here, root_PE, num_PEs +! Single call communication routines +public :: pass_var, pass_vector, fill_symmetric_edges, broadcast +! Non-blocking communication routines +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +! Multi-variable group communication routines and type +public :: create_group_pass, do_group_pass, group_pass_type, start_group_pass, complete_group_pass +! Global reduction routines public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: create_group_pass, do_group_pass, group_pass_type -public :: start_group_pass, complete_group_pass -public :: compute_block_extent, get_global_shape, get_layout_extents +! Coded integers for controlling communication or staggering public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM public :: CORNER, CENTER, NORTH_FACE, EAST_FACE public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners From 21080d7e7193312b7df2718efc2569c959d7e149 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 19 Jan 2021 07:55:02 -0500 Subject: [PATCH 148/212] +Add explicit interface for init_external_field Creates and uses an explicit interface for init_extern_field, including a new optional MOM_domain_type argument, and the omission of some of the optional arguments to the FMS version of init_external_field that are unused in MOM6. All answers are bitwise identical, but there are changes to the optional argument to the optional arguments in a public interface. --- .../MOM_surface_forcing_gfdl.F90 | 4 +-- src/core/MOM_open_boundary.F90 | 8 ++--- src/framework/MOM_interp_infra.F90 | 30 ++++++++++++++++++- src/framework/MOM_interpolate.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf.F90 | 6 ++-- .../vertical/MOM_ALE_sponge.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 2 +- 7 files changed, 42 insertions(+), 14 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 44e1fb14d2..4d2d9dec9b 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1557,7 +1557,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, domain=G%Domain%mpp_domain) + CS%id_srestore = 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' @@ -1567,7 +1567,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, domain=G%Domain%mpp_domain) + CS%id_trestore = 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/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 71e2aeeb5b..9672356bf6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -859,8 +859,8 @@ subroutine initialize_segment_data(G, OBC, PF) endif endif segment%field(m)%buffer_src(:,:,:)=0.0 - segment%field(m)%fid = init_external_field(trim(filename),& - trim(fieldname),ignore_axis_atts=.true.,threading=SINGLE_FILE) + segment%field(m)%fid = 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 ! siz(3) is constituent for tidal variables @@ -890,8 +890,8 @@ subroutine initialize_segment_data(G, 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),& - ignore_axis_atts=.true.,threading=SINGLE_FILE) + segment%field(m)%fid_dz = init_external_field(trim(filename), trim(fieldname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) endif else segment%field(m)%nk_src=1 diff --git a/src/framework/MOM_interp_infra.F90 b/src/framework/MOM_interp_infra.F90 index e062edcaac..d9de006224 100644 --- a/src/framework/MOM_interp_infra.F90 +++ b/src/framework/MOM_interp_infra.F90 @@ -3,6 +3,7 @@ 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_infra, only : axistype use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type @@ -13,7 +14,7 @@ module MOM_interp_infra implicit none ; private -public :: time_interp_extern, init_external_field, time_interp_external_init +public :: time_interp_extern, init_extern_field, time_interp_external_init public :: get_external_field_info public :: horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new @@ -97,4 +98,31 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_3d +integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts ) + + 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 + integer, optional, intent(in) :: threading !< A flag specifying whether the root PE reads + !! the data and broadcasts it (SINGLE_FILE) or all + !! processors read (MULTIPLE, the default). + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + 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 + integer, optional, intent(out) :: ierr !< Returns a non-zero error code in case of failure + logical, optional, intent(in) :: ignore_axis_atts !< If present and true, do not issue a + !! fatal error if the axis Cartesian attribute is + !! not set to a recognized value. + + 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) + else + init_extern_field = init_external_field(file, fieldname, domain=domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts) + endif + +end function init_extern_field + end module MOM_interp_infra diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 0e313ed478..6a5a4b2cc6 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -5,8 +5,8 @@ module MOM_interpolate use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL -use MOM_interp_infra, only : time_interp_extern, init_external_field, time_interp_external_init -use MOM_interp_infra, only : get_external_field_info +use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field +use MOM_interp_infra, only : time_interp_external_init, get_external_field_info use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ac951602fc..4149e1be01 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1933,15 +1933,15 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) CS%id_read_mass = init_external_field(filename, shelf_mass_var, & - domain=CS%Grid_in%Domain%mpp_domain, verbose=CS%debug) + MOM_domain=CS%Grid_in%Domain, verbose=CS%debug) if (read_shelf_area) then call get_param(param_file, mdl, "SHELF_AREA_VAR", shelf_area_var, & "The variable in SHELF_FILE with the shelf area.", & default="shelf_area") - CS%id_read_area = init_external_field(filename,shelf_area_var, & - domain=CS%Grid_in%Domain%mpp_domain) + CS%id_read_area = init_external_field(filename, shelf_area_var, & + MOM_domain=CS%Grid_in%Domain) endif if (.not.file_exists(filename, CS%Grid_in%Domain)) call MOM_error(FATAL, & diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 4fde518cd8..548b1d04f4 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -639,7 +639,7 @@ 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 ongrid, then setup ! to only read on the computational domain if (CS%spongeDataOngrid) then - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) + CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname, MOM_domain=G%Domain) else CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) endif diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e9c5e847e1..ee27c6c5df 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1693,7 +1693,7 @@ 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), domain=G%Domain%mpp_domain) + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) endif CS%id_chl = register_diag_field('ocean_model', 'Chl_opac', diag%axesT1, Time, & From abf6819d1a9b0351bfd62bbe8e52fd3790f392d7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 10:37:51 -0500 Subject: [PATCH 149/212] Adds back a bug providing the wrong time to diabatic processes - Provides an option to undo the bug fix bc6c6e65d658f7cdd that corrected the time used by diabatic processes. - A new run-time parameter, USE_DIABATIC_TIME_BUG, turns on the bug with documentation stating this is not recommended. The default is false, and is independent of DEFAULT_2018_ANSWERS. - This addresses part of NOAA-GFDL/MOM6#1271. --- src/core/MOM.F90 | 35 ++++++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ce0343f714..10a8a81d0e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -255,6 +255,8 @@ module MOM 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 !! barotropic time step [s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. @@ -663,9 +665,15 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS rel_time = 0.0 do n=1,n_max - rel_time = rel_time + dt ! The relative time at the end of the step. - ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + if (CS%use_diabatic_time_bug) then + ! This wrong form of update was used until Feb 2018, recovered with CS%use_diabatic_time_bug=T. + CS%Time = Time_start + real_to_time(US%T_to_s*int(floor(rel_time+0.5*dt+0.5))) + rel_time = rel_time + dt + else + rel_time = rel_time + dt ! The relative time at the end of the step. + ! Set the universally visible time to the middle of the time step. + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + endif ! Set the local time to the end of the time step. Time_local = Time_start + real_to_time(US%T_to_s*rel_time) @@ -695,12 +703,16 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif end_time_thermo = Time_local - if (dtdia > dt) then + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) then ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they begin at the same time. + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt)) + endif + if (dtdia > dt .or. CS%use_diabatic_time_bug) then ! The end-time of the diagnostic interval needs to be set ahead if there ! are multiple dynamic time steps worth of thermodynamics applied here. + ! This line was not conditional prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. end_time_thermo = Time_local + real_to_time(US%T_to_s*(dtdia-dt)) endif @@ -713,7 +725,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS CS%t_dyn_rel_thermo = -dtdia if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") - if (dtdia > dt) & ! Reset CS%Time to its previous value. + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & ! Reset CS%Time to its previous value. + ! This step was missing prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" @@ -800,7 +813,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - if (dtdia > dt) CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt)) + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & + CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt)) ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & @@ -814,7 +829,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS CS%t_dyn_rel_thermo = 0.0 endif - if (dtdia > dt) & ! Reset CS%Time to its previous value. + ! Reset CS%Time to its previous value. + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) endif @@ -2000,6 +2017,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "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) + 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 "//& + "done in MOM6 versions prior to February 2018. This is not recommended.", & + default=.false.) call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & "If true, write the initial conditions to a file given "//& From f499d99c2594de155b11a103b9895179400ef2c3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 10:46:47 -0500 Subject: [PATCH 150/212] Adds back a less accurate form of the PGF - Provides an option to undo enhancement NOAA-GFDL/MOM6@48e90d0b92 that significantly improved the accuracy of density anomaly calculations within the FV pressure gradient force. - A new run-time parameter, USE_INACCURATE_PGF_RHO_ANOM, turns on the less accurate form with documentation stating this is not recommended. The default is false, and is independent of DEFAULT_2018_ANSWERS. - This addresses part of NOAA-GFDL/MOM6#1271. --- src/core/MOM_PressureForce_FV.F90 | 9 +- src/core/MOM_density_integrals.F90 | 221 +++++++++++++++++++++-------- 2 files changed, 173 insertions(+), 57 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index e5e37ecc8d..89a7a1faff 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -43,6 +43,9 @@ module MOM_PressureForce_FV type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate + !! method to calculate density anomalies, as used prior to + !! March 2018. logical :: boundary_extrap !< Indicate whether high-order boundary !! extrapolation should be used within boundary cells @@ -696,7 +699,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp=CS%useMassWghtInterp) + useMassWghtInterp=CS%useMassWghtInterp, & + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & @@ -838,6 +842,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "If true, use mass weighting when interpolating T/S for "//& "integrals near the bathymetry in FV pressure gradient "//& "calculations.", default=.false.) + call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & + "If true, use a form of the PGF that uses the reference density "//& + "in an inaccurate way. This is not recommended.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & "If True, use vertical reconstruction of T & S within "//& "the integrals of the FV pressure gradient calculation. "//& diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8d71cbcf65..302ba0a714 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -94,7 +94,7 @@ end subroutine int_density_dz !! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, dz_neglect, useMassWghtInterp, use_inaccurate_form) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [degC] @@ -134,6 +134,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of + !! density anomalies, as was used prior to March 2018. ! Local variables real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] @@ -156,6 +158,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: intz(5) ! The gravitational acceleration times the integrals of density ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] 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 ! These array bounds work for the indexing convention of the input arrays, but @@ -169,6 +173,10 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & GxRho = US%RL2_T2_to_Pa * G_e * rho_0 rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 + use_rho_ref = .true. + if (present(use_inaccurate_form)) then + if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + endif do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -185,14 +193,24 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & T5(n) = T(i,j) ; S5(n) = S(i,j) p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + 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)) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + 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)) - 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 ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of ! the pressure anomaly. @@ -231,14 +249,24 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + 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))) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + 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)) - rho_ref ) 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 ! 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)) + & @@ -277,14 +305,24 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & T5(n) = T5(1) ; S5(n) = S5(1) p5(n) = p5(n-1) + GxRho*0.25*dz enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + 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))) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + 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)) - rho_ref ) 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 ! 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)) + & @@ -297,7 +335,8 @@ end subroutine int_density_dz_generic_pcm !! T and S are linear profiles. subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, & + use_inaccurate_form) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -338,6 +377,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !! divided by the y grid spacing [R L2 T-2 ~> Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of + !! density anomalies, as was used prior to March 2018. ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -357,9 +398,11 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa] + ! rescaled from Pa [Pa] real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3] + ! locations [R ~> kg m-3] or [kg m-3] + real :: u5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid locations + ! (used for inaccurate form) [R ~> kg m-3] or [kg m-3] real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] @@ -388,7 +431,9 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] logical :: use_stanley_eos ! True is SGS variance fields exist in tv. - logical :: use_varT, use_varS, use_covarTS + 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 :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: pos @@ -402,6 +447,10 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (present(useMassWghtInterp)) then if (useMassWghtInterp) massWeightToggle = 1. endif + use_rho_ref = .true. + if (present(use_inaccurate_form)) then + if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + endif use_varT = associated(tv%varT) use_covarTS = associated(tv%covarTS) @@ -442,25 +491,49 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_ref=rho_ref_mks) endif else - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & - scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif else - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS) + endif + u5(:) = r5(:) - rho_ref endif endif - 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)) - 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. - 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 - enddo + if (use_rho_ref) then + 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)) + 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. + 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 + enddo + else + 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)) & + - 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. + 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 + enddo + endif enddo ! end loops on j ! 2. Compute horizontal integrals in the x direction @@ -535,11 +608,19 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_ref=rho_ref_mks) endif else - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & - scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS) + endif endif endif @@ -547,11 +628,19 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) ! Use Boole's rule to estimate the pressure anomaly change. - 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 + if (use_rho_ref) then + 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 + 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)) @@ -633,13 +722,24 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) endif else - if (rho_scale /= 1.0) then - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) + if (use_rho_ref) then + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif else - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS) + endif endif endif @@ -647,12 +747,21 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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 - 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 + if (use_rho_ref) then + do m = 2,4 + 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 + else + do m = 2,4 + 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)) - rho_ref ) + enddo + 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)) From e7b7b6226819bd6b0bc633139a21dab52d8130ab Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 10:50:40 -0500 Subject: [PATCH 151/212] Adds back an older form of neutral diffusion transport accumulation - Provides an option to undo enhancement NOAA-GFDL/MOM6@8f4af3d9ef927dc4b9 that masked transports and replaced a division by a multiply by the reciprocal. - A new run-time parameter, NDIFF_USE_UNMASKED_TRANSPORT_BUG, turns on the less older form with documentation stating this is not recommended. The default is false, and is independent of DEFAULT_2018_ANSWERS. - This addresses part of NOAA-GFDL/MOM6#1271. --- src/tracer/MOM_neutral_diffusion.F90 | 29 ++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 50ce18eb57..d8edff3751 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -53,6 +53,8 @@ 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 :: 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 @@ -166,6 +168,10 @@ 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.) + 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 "//& + "recommended.", default = .false.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then @@ -498,12 +504,23 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! calculates hEff from the nondimensional fraction of the layer spanned by adjacent neutral ! surfaces, so hEff is already in thickness units. if (CS%continuous_reconstruction) then - do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H - enddo ; enddo ; enddo - do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H - enddo ; enddo ; enddo + if (CS%use_unmasked_transport_bug) then + ! This option is not recommended but needed to recover answers prior to Jan 2018. + ! It is independent of the other 2018 answers flags. + do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + CS%uhEff(I,j,k) = CS%uhEff(I,j,k) / GV%H_to_pa + enddo ; enddo ; enddo + do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + CS%vhEff(I,j,k) = CS%vhEff(I,j,k) / GV%H_to_pa + enddo ; enddo ; enddo + else + do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H + enddo ; enddo ; enddo + do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + enddo ; enddo ; enddo + endif endif if (CS%id_uhEff_2d>0) then From a85c91822e0c6f672f836016a1b80a5a6e519e59 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 12:03:28 -0500 Subject: [PATCH 152/212] Adds back an indexing bug for the background viscosity - Adds back a bug enabling option that was removed as part of a larger commit, NOAA-GFDL/MOM6@74dcb13706d2977d679d4fe7b45cb97f73d6b20a. The option enabled incorrect indexing at q-points of a 2D background viscosity. - The run-time parameter, KH_BG_2D_BUG, has been removed from the list of obsolete parameters and now turns on the bug above. The older documentationform has been updated to state that this is not recommended. The default is false, and is independent of DEFAULT_2018_ANSWERS. - This addresses part of NOAA-GFDL/MOM6#1271. --- src/diagnostics/MOM_obsolete_params.F90 | 1 - .../lateral/MOM_hor_visc.F90 | 19 ++++++++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index a38f5a4b54..80708df97b 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -60,7 +60,6 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) call obsolete_logical(param_file, "MLE_USE_MLD_AVE_BUG", .false.) - call obsolete_logical(param_file, "KG_BG_2D_BUG", .false.) call obsolete_logical(param_file, "CORRECT_DENSITY", .true.) call obsolete_char(param_file, "WINDSTRESS_STAGGER", warning_val="C", & hint="Use WIND_STAGGER instead.") diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 003b134b2a..fc6d97040a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -71,6 +71,8 @@ module MOM_hor_visc !! viscosity is modified to include a term that !! scales quadratically with the velocity shears. logical :: use_Kh_bg_2d !< Read 2d background viscosity from a file. + logical :: 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. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. logical :: use_land_mask !< Use the land mask for the computation of thicknesses @@ -1954,6 +1956,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) + if (CS%use_Kh_bg_2d) then + 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"//& + "not recommended.", default=.false.) + endif call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& @@ -2157,9 +2165,14 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2)) ! Use the larger of the above and values read from a file if (CS%use_Kh_bg_2d) then - CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_xy(I,J), & - 0.25*((CS%Kh_bg_2d(i,j) + CS%Kh_bg_2d(i+1,j+1)) + & - (CS%Kh_bg_2d(i+1,j) + CS%Kh_bg_2d(i,j+1))) ) + if (CS%Kh_bg_2d_bug) then + ! This option is unambiguously wrong but is needed to recover old answers + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) + else + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_xy(I,J), & + 0.25*((CS%Kh_bg_2d(i,j) + CS%Kh_bg_2d(i+1,j+1)) + & + (CS%Kh_bg_2d(i+1,j) + CS%Kh_bg_2d(i,j+1))) ) + endif endif ! Use the larger of the above and a function of sin(latitude) From 172025dd87ef1042d652286e0eccd0f56dc56fd9 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Wed, 20 Jan 2021 12:24:14 -0500 Subject: [PATCH 153/212] add documentation for function ChkErr --- config_src/nuopc_driver/mom_cap_methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 39f450d453..4946fc9927 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -940,9 +940,9 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) end subroutine field_getfldptr logical function ChkErr(rc, line, file) - integer, intent(in) :: rc - integer, intent(in) :: line - character(len=*), intent(in) :: file + integer, intent(in) :: rc !< return code to check + integer, intent(in) :: line !< Integer source line number + character(len=*), intent(in) :: file !< User-provided source file name integer :: lrc ChkErr = .false. lrc = rc From c05b042d9e9e16efc6afb36a0e8d8a888d82bde2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 14:54:46 -0500 Subject: [PATCH 154/212] Added API documentation for chkerr() --- config_src/nuopc_driver/mom_cap_methods.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 4946fc9927..78014f1c63 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -939,6 +939,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) end subroutine field_getfldptr +!> Returns true if ESMF_LogFoundError() determines that rc is an error code. Otherwise false. logical function ChkErr(rc, line, file) integer, intent(in) :: rc !< return code to check integer, intent(in) :: line !< Integer source line number From ea5e2458fbd8b39f07e7598195d39f54c352a78a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 Jan 2021 18:02:52 -0500 Subject: [PATCH 155/212] Fixed white space and line length --- .../nuopc_driver/mom_surface_forcing_nuopc.F90 | 2 +- src/core/MOM_forcing_type.F90 | 16 ++++++++-------- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 ++++++------ src/user/MOM_wave_interface.F90 | 4 ++-- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 585117c3ba..689a9f0f4a 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -862,7 +862,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) enddo; enddo call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) enddo - endif + endif ! sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a135107025..f0cc8f553c 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3007,8 +3007,8 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & logical, optional, intent(in) :: shelf !< If present and true, allocate forces for ice-shelf logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields 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) :: waves !< If present and true, allocate wave fields + integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -3038,16 +3038,16 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & !These fields should only be allocated when waves call myAlloc(forces%ustk0,isd,ied,jsd,jed, waves) call myAlloc(forces%vstk0,isd,ied,jsd,jed, waves) - if (present(waves)) then; if (waves) then; if (.not.associated(forces%ustkb)) then + if (present(waves)) then; if (waves) then; if (.not.associated(forces%ustkb)) then if (.not.(present(num_stk_bands))) call MOM_error(FATAL,"Requested to & - initialize with waves, but no waves are present.") - allocate(forces%stk_wavenumbers(num_stk_bands)) - forces%stk_wavenumbers(:) = 0.0 - allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) + initialize with waves, but no waves are present.") + allocate(forces%stk_wavenumbers(num_stk_bands)) + forces%stk_wavenumbers(:) = 0.0 + allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) forces%ustkb(isd:ied,jsd:jed,:) = 0.0 endif ; endif ; endif - if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then + if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands)) forces%vstkb(isd:ied,jsd:jed,:) = 0.0 endif ; endif ; endif diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 2b7a5646cc..01d8e4163b 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -579,13 +579,13 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ type(lbd_CS), pointer :: CS !< Lateral diffusion control structure !! the boundary layer ! Local variables - real, dimension(:), allocatable :: dz_top !< The LBD z grid to be created [L ~ m] - real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] - real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] - real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U- or V-point in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(:), allocatable :: dz_top !< The LBD z grid to be created [L ~ m] + real, dimension(:), allocatable :: phi_L_z !< Tracer values in the ztop grid (left) [conc] + real, dimension(:), allocatable :: phi_R_z !< Tracer values in the ztop grid (right) [conc] + real, dimension(:), allocatable :: F_layer_z !< Diffusive flux at U/V-point 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 :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. real :: htot !< Total column thickness [H ~> m or kg m-2] diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 6352774fa7..0780ca5e3d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -466,9 +466,9 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) if (DataSource==DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) elseif (DataSource==Coupler) then - if (.not.present(FORCES)) then + if (.not.present(FORCES)) then call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& - "this driver. If you are using a coupled driver with a wave model then "//& + "this driver. If you are using a coupled driver with a wave model then "//& "check the arguments in the subroutine call to Update_Surface_Waves, "//& "otherwise select another option for SURFBAND_SOURCE.") endif From 695a14f10eea4ae4da38183557eb18f006871e98 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 21 Jan 2021 20:20:53 -0500 Subject: [PATCH 156/212] Resolved comments in PR discussion --- src/framework/MOM_error_handler.F90 | 3 --- src/ice_shelf/user_shelf_init.F90 | 1 - 2 files changed, 4 deletions(-) diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 57f861e282..336a4942be 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -39,9 +39,6 @@ module MOM_error_handler contains -! is_root_pe returns .true. if the current PE is the root PE. -! function is_root_pe() - !> This provides a convenient interface for writing an informative comment. subroutine MOM_mesg(message, verb, all_print) character(len=*), intent(in) :: message !< A message to write out diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index c9370ead8f..9635f51262 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -9,7 +9,6 @@ module user_shelf_init use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, set_time, time_type_to_real use MOM_unit_scaling, only : unit_scale_type -! use MOM_io, only : file_exists, read_data, slasher implicit none ; private From 7cd558ef7c4c766a40a2551a2a936b227e81a41b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 21 Jan 2021 20:24:54 -0500 Subject: [PATCH 157/212] Show style errors in GH actions log --- .github/workflows/documentation-and-style.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml index c83de48159..c171c538d5 100644 --- a/.github/workflows/documentation-and-style.yml +++ b/.github/workflows/documentation-and-style.yml @@ -14,7 +14,7 @@ jobs: - name: Check white space (non-blocking) run: | - ./.testing/trailer.py -e TEOS10 -l 120 src config_src | tee style_errors + ./.testing/trailer.py -e TEOS10 -l 120 src config_src 2>&1 | tee style_errors continue-on-error: true - name: Install packages used when generating documentation @@ -35,4 +35,5 @@ jobs: run: | grep "warning:" docs/_build/doxygen_warn_nortd_log.txt | grep -v "as part of a" | tee doxy_errors cat style_errors doxy_errors > all_errors + cat all_errors test ! -s all_errors From 3126f0592c702b3003397e0a33e4ce8516ce9bd1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 24 Jan 2021 08:08:45 -0500 Subject: [PATCH 158/212] +Made get_domain_extent work with domain2D types Overloaded get_domain_extent to extract index ranges with domain2D types as well as MOM_domain_types. Also made the global extent arguments optional to get_domain_extent_MD. All answers are bitwise identical. --- src/framework/MOM_domain_infra.F90 | 91 +++++++++++++++++++++--------- 1 file changed, 64 insertions(+), 27 deletions(-) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 482e01871f..5ced2e33c0 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -111,6 +111,12 @@ module MOM_domain_infra module procedure get_domain_components_MD, get_domain_components_d2D end interface get_domain_components +!> Returns the index ranges that have been stored in a MOM_domain_type +interface get_domain_extent + module procedure get_domain_extent_MD, get_domain_extent_d2D +end interface get_domain_extent + + !> The MOM_domain_type contains information about the domain decomposition. type, public :: MOM_domain_type character(len=64) :: name !< The name of this domain @@ -1626,38 +1632,39 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & end subroutine clone_MD_to_d2D -!> Returns various data that has been stored in a MOM_domain_type -subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & - isg, ieg, jsg, jeg, idg_offset, jdg_offset, & - symmetric, local_indexing, index_offset, coarsen) +!> Returns the index ranges that have been stored in a MOM_domain_type +subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset, coarsen) type(MOM_domain_type), & - intent(in) :: Domain !< The MOM domain from which to extract information - integer, intent(out) :: isc !< The start i-index of the computational domain - integer, intent(out) :: iec !< The end i-index of the computational domain - integer, intent(out) :: jsc !< The start j-index of the computational domain - integer, intent(out) :: jec !< The end j-index of the computational domain - integer, intent(out) :: isd !< The start i-index of the data domain - integer, intent(out) :: ied !< The end i-index of the data domain - integer, intent(out) :: jsd !< The start j-index of the data domain - integer, intent(out) :: jed !< The end j-index of the data domain - integer, intent(out) :: isg !< The start i-index of the global domain - integer, intent(out) :: ieg !< The end i-index of the global domain - integer, intent(out) :: jsg !< The start j-index of the global domain - integer, intent(out) :: jeg !< The end j-index of the global domain + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, optional, intent(out) :: isg !< The start i-index of the global domain + integer, optional, intent(out) :: ieg !< The end i-index of the global domain + integer, optional, intent(out) :: jsg !< The start j-index of the global domain + integer, optional, intent(out) :: jeg !< The end j-index of the global domain integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and - !! data i-index spaces. + !! data i-index spaces. integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and - !! data j-index spaces. + !! data j-index spaces. logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, - !! as in most MOM6 code. + !! as in most MOM6 code. The default is true. integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This !! can be useful for some types of debugging with - !! dynamic memory allocation. + !! dynamic memory allocation. The default is 0. integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. !! The default is 1, for no coarsening. ! Local variables + integer :: isg_, ieg_, jsg_, jeg_ integer :: ind_off, idg_off, jdg_off, coarsen_lev logical :: local @@ -1669,22 +1676,22 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & if (coarsen_lev == 1) then call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain, isg, ieg, jsg, jeg) + call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_) elseif (coarsen_lev == 2) then if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain_d2, isg, ieg, jsg, jeg) + call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_) else call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") endif if (local) then ! This code institutes the MOM convention that local array indices start at 1. - idg_off = isd-1 ; jdg_off = jsd-1 - isc = isc-isd+1 ; iec = iec-isd+1 ; jsc = jsc-jsd+1 ; jec = jec-jsd+1 - ied = ied-isd+1 ; jed = jed-jsd+1 + idg_off = isd - 1 ; jdg_off = jsd - 1 + isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1 + ied = ied - isd + 1 ; jed = jed - jsd + 1 isd = 1 ; jsd = 1 else idg_off = 0 ; jdg_off = 0 @@ -1696,11 +1703,41 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & isd = isd + ind_off ; ied = ied + ind_off jsd = jsd + ind_off ; jed = jed + ind_off endif + if (present(isg)) isg = isg_ + if (present(ieg)) ieg = ieg_ + if (present(jsg)) jsg = jsg_ + if (present(jeg)) jeg = jeg_ if (present(idg_offset)) idg_offset = idg_off if (present(jdg_offset)) jdg_offset = jdg_off if (present(symmetric)) symmetric = Domain%symmetric -end subroutine get_domain_extent +end subroutine get_domain_extent_MD + +!> Returns the index ranges that have been stored in a domain2D type +subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) + type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, optional, intent(out) :: isd !< The start i-index of the data domain + integer, optional, intent(out) :: ied !< The end i-index of the data domain + integer, optional, intent(out) :: jsd !< The start j-index of the data domain + integer, optional, intent(out) :: jed !< The end j-index of the data domain + + ! Local variables + integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) + + if (present(isd)) isd = isd_ + if (present(ied)) ied = ied_ + if (present(jsd)) jsd = jsd_ + if (present(jed)) jed = jed_ + +end subroutine get_domain_extent_d2D + !> Return the (potentially symmetric) computational domain i-bounds for an array !! passed without index specifications (i.e. indices start at 1) based on an array size. From 74f229018dbb9cd8e0aba924a7874723e0206b2e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 24 Jan 2021 08:09:30 -0500 Subject: [PATCH 159/212] +Added MOM_coupler_types.F90 Added MOM_coupler_types.F90 and MOM_couplertype_infra.F90 to provide explicit interfaces for the routines from coupler_type_mod that MOM6 uses, with some new interfaces, extract_coupler_type_data and set_coupler_type_data, that are tailored to their use in MOM6. All answers are bitwise identical, but there are some new public interfaces. --- src/framework/MOM_coupler_types.F90 | 235 ++++++++++++++++++++++ src/framework/MOM_couplertype_infra.F90 | 247 ++++++++++++++++++++++++ 2 files changed, 482 insertions(+) create mode 100644 src/framework/MOM_coupler_types.F90 create mode 100644 src/framework/MOM_couplertype_infra.F90 diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 new file mode 100644 index 0000000000..94014d9a56 --- /dev/null +++ b/src/framework/MOM_coupler_types.F90 @@ -0,0 +1,235 @@ +!> This module provides coupler type interfaces for use by MOM6 +module MOM_coupler_types + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux +use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums +use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_set_data, CT_extract_data +use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_couplertype_infra, only : ind_flux, ind_alpha, ind_csurf + +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: coupler_type_spawn, coupler_type_destructor, coupler_type_initialized +public :: coupler_type_set_diags, coupler_type_send_data, coupler_type_write_chksums +public :: set_coupler_type_data, extract_coupler_type_data +public :: coupler_type_copy_data, coupler_type_increment_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface coupler_type_spawn + module procedure CT_spawn_1d_2d, CT_spawn_2d_2d +end interface coupler_type_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface coupler_type_initialized + module procedure CT_initialized_1d, CT_initialized_2d +end interface coupler_type_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface coupler_type_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface coupler_type_destructor + +contains + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine coupler_type_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine coupler_type_increment_data(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine coupler_type_increment_data + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a +!! MOM-specific interface. +subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & + halo_size, idim, jdim, field_index) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + integer, optional, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + + if (present(field_index)) then + call CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + else + call CT_extract_data(var_in, bc_index, ind_flux, array_out, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + endif + +end subroutine extract_coupler_type_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a +!! MOM-specific interface. +subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & + halo_size, idim, jdim, field_index) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + logical, optional, intent(in) :: solubility !< If true and field index is missing, set + !! the solubility field. Otherwise set the + !! surface concentration (the default). + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + + integer :: subfield ! An integer indicating which field to set. + + subfield = ind_csurf + if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif + if (present(field_index)) subfield = field_index + + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + +end subroutine set_coupler_type_data + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine coupler_type_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call CT_set_diags(var, diag_name, axes, time) + +end subroutine coupler_type_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine coupler_type_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call CT_send_data(var, Time) +end subroutine coupler_type_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine coupler_type_write_chksums(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call CT_write_chksums(var, outunit, name_lead) + +end subroutine coupler_type_write_chksums + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = CT_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = CT_initialized(var) +end function CT_initialized_2d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call CT_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call CT_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_coupler_types diff --git a/src/framework/MOM_couplertype_infra.F90 b/src/framework/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..fd947691ca --- /dev/null +++ b/src/framework/MOM_couplertype_infra.F90 @@ -0,0 +1,247 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use coupler_types_mod, only : coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_copy_data, coupler_type_increment_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_write_chksums +public :: CT_set_data, CT_increment_data +public :: CT_copy_data, CT_extract_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_2d_2d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + integer :: subfield ! An integer indicating which field to set. + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra From 9ad5dcbac30c0b04b0f02537250db2dcc34cca09 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 24 Jan 2021 08:14:41 -0500 Subject: [PATCH 160/212] Use new MOM_coupler_types interfaces with tracers Modified the various MOM6 tracer packages to use the MOM_coupler_types module along with new and simpler MOM_coupler_types interfaces. Also modified the module use statements in some of the core and diagnostics modules to access the coupler_types routines via MOM_coupler_types module. All answers are bitwise identical. --- src/core/MOM.F90 | 1 - src/core/MOM_forcing_type.F90 | 10 +++--- src/core/MOM_variables.F90 | 19 +++++----- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/tracer/DOME_tracer.F90 | 13 +++---- src/tracer/ISOMIP_tracer.F90 | 13 +++---- src/tracer/MOM_OCMIP2_CFC.F90 | 48 ++++++++++++-------------- src/tracer/advection_test_tracer.F90 | 13 +++---- src/tracer/boundary_impulse_tracer.F90 | 13 +++---- src/tracer/dye_example.F90 | 13 +++---- src/tracer/dyed_obc_tracer.F90 | 8 ++--- src/tracer/ideal_age_example.F90 | 13 +++---- src/tracer/oil_tracer.F90 | 13 +++---- src/tracer/pseudo_salt_tracer.F90 | 3 -- src/tracer/tracer_example.F90 | 13 +++---- 15 files changed, 79 insertions(+), 116 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 23aa866b90..9127924cfb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -47,7 +47,6 @@ module MOM use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_time_manager, only : operator(>=), operator(==), increment_date use MOM_unit_tests, only : unit_tests -use coupler_types_mod, only : coupler_type_send_data, coupler_1d_bc_type, coupler_type_spawn ! MOM core modules use MOM_ALE, only : ALE_init, ALE_end, ALE_main, ALE_CS, adjustGridForIntegrity diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dd6b92da2d..682ad03397 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -4,13 +4,15 @@ module MOM_forcing_type ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair -use MOM_debugging, only : hchksum, uvchksum +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_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 use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging -use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_EOS, only : calculate_density_derivs, 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 use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands @@ -19,10 +21,6 @@ module MOM_forcing_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_spawn -use coupler_types_mod, only : coupler_type_increment_data, coupler_type_initialized -use coupler_types_mod, only : coupler_type_copy_data, coupler_type_destructor - implicit none ; private #include diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 2cfce980dc..d81cf28e17 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -4,16 +4,14 @@ module MOM_variables ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array, rotate_vector -use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type -use MOM_debugging, only : hchksum +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_debugging, only : hchksum +use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type +use MOM_EOS, only : EOS_type use MOM_error_handler, only : MOM_error, FATAL -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : EOS_type - -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_destructor -use coupler_types_mod, only : coupler_type_initialized +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -471,8 +469,7 @@ subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) ! 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.") + call MOM_error(FATAL, "Rotation of surface state tracers is not yet implemented.") end subroutine rotate_surface_state !> Allocates the arrays contained within a BT_cont_type and initializes them to 0. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 6a53ffb1fc..47d322dfa0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -6,6 +6,7 @@ module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : reproducing_sum +use MOM_coupler_types, only : coupler_type_send_data use MOM_density_integrals, only : int_density_dz use MOM_diag_mediator, only : post_data, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field @@ -30,7 +31,6 @@ module MOM_diagnostics use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init -use coupler_types_mod, only : coupler_type_send_data implicit none ; private diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index b9e9196ffa..c20eda7745 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -3,6 +3,7 @@ module DOME_tracer ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -21,9 +22,6 @@ module DOME_tracer use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -48,7 +46,7 @@ module DOME_tracer real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. - integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -130,7 +128,7 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & flux_type=' ', implementation=' ', caller="register_DOME_tracer") enddo @@ -359,9 +357,8 @@ subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,NTR ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index ce997d6af1..0e31282e9c 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -11,6 +11,7 @@ module ISOMIP_tracer ! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 use MOM_coms, only : max_across_PEs +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 @@ -28,9 +29,6 @@ module ISOMIP_tracer use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -51,7 +49,7 @@ module ISOMIP_tracer real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. - integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux + 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. @@ -135,7 +133,7 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & flux_type=' ', implementation=' ', caller="register_ISOMIP_tracer") enddo @@ -345,9 +343,8 @@ subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 3e007cbe7a..4e5813e42a 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -3,6 +3,8 @@ module MOM_OCMIP2_CFC ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data +use MOM_coupler_types, only : 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 @@ -21,10 +23,6 @@ module MOM_OCMIP2_CFC use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf -use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -71,9 +69,9 @@ module MOM_OCMIP2_CFC character(len=16) :: CFC11_name !< CFC11 variable name character(len=16) :: CFC12_name !< CFC12 variable name - integer :: ind_cfc_11_flux !< Index returned by aof_set_coupler_flux that is used to + integer :: ind_cfc_11_flux !< Index returned by atmos_ocn_coupler_flux that is used to !! pack and unpack surface boundary condition arrays. - integer :: ind_cfc_12_flux !< Index returned by aof_set_coupler_flux that is used to + integer :: ind_cfc_12_flux !< Index returned by atmos_ocn_coupler_flux that is used to !! pack and unpack surface boundary condition arrays. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate @@ -127,7 +125,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! indicies for the CFC11 and CFC12 flux coupling. call flux_init_OCMIP2_CFC(CS, verbosity=3) if ((CS%ind_cfc_11_flux < 0) .or. (CS%ind_cfc_12_flux < 0)) then - ! This is most likely to happen with the dummy version of aof_set_coupler_flux + ! This is most likely to happen with the dummy version of atmos_ocn_coupler_flux ! used in ocean-only runs. call MOM_ERROR(WARNING, "CFCs are currently only set up to be run in " // & " coupled model configurations, and will be disabled.") @@ -291,18 +289,18 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) ! These calls obtain the indices for the CFC11 and CFC12 flux coupling. They ! can safely be called multiple times. - ind_flux(1) = aof_set_coupler_flux('cfc_11_flux', & - flux_type = 'air_sea_gas_flux', implementation = 'ocmip2', & - param = (/ 9.36e-07, 9.7561e-06 /), & + ind_flux(1) = atmos_ocn_coupler_flux('cfc_11_flux', & + flux_type = 'air_sea_gas_flux', implementation='ocmip2', & + param=(/ 9.36e-07, 9.7561e-06 /), & ice_restart_file = default_ice_restart_file, & ocean_restart_file = default_ocean_restart_file, & caller = "register_OCMIP2_CFC", verbosity=verbosity) - ind_flux(2) = aof_set_coupler_flux('cfc_12_flux', & - flux_type = 'air_sea_gas_flux', implementation = 'ocmip2', & + ind_flux(2) = atmos_ocn_coupler_flux('cfc_12_flux', & + flux_type='air_sea_gas_flux', implementation='ocmip2', & param = (/ 9.36e-07, 9.7561e-06 /), & - ice_restart_file = default_ice_restart_file, & - ocean_restart_file = default_ocean_restart_file, & - caller = "register_OCMIP2_CFC", verbosity=verbosity) + ice_restart_file=default_ice_restart_file, & + ocean_restart_file=default_ocean_restart_file, & + caller="register_OCMIP2_CFC", verbosity=verbosity) if (present(CS)) then ; if (associated(CS)) then CS%ind_cfc_11_flux = ind_flux(1) @@ -459,9 +457,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! These two calls unpack the fluxes from the input arrays. ! The -GV%Rho0 changes the sign convention of the flux and changes the units ! of the flux from [Conc. m s-1] to [Conc. kg m-2 T-1]. - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, CFC11_flux, & + call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, CFC12_flux, & + call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) ! Use a tridiagonal solver to determine the concentrations after the @@ -602,14 +600,14 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. - call coupler_type_set_data(CFC11_alpha, CS%ind_cfc_11_flux, ind_alpha, & - sfc_state%tr_fields, idim=idim, jdim=jdim) - call coupler_type_set_data(CFC11_Csurf, CS%ind_cfc_11_flux, ind_csurf, & - sfc_state%tr_fields, idim=idim, jdim=jdim) - call coupler_type_set_data(CFC12_alpha, CS%ind_cfc_12_flux, ind_alpha, & - sfc_state%tr_fields, idim=idim, jdim=jdim) - call coupler_type_set_data(CFC12_Csurf, CS%ind_cfc_12_flux, ind_csurf, & - sfc_state%tr_fields, idim=idim, jdim=jdim) + call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & + solubility=.true., idim=idim, jdim=jdim) + call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & + idim=idim, jdim=jdim) + call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & + solubility=.true., idim=idim, jdim=jdim) + call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & + idim=idim, jdim=jdim) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index b4dd93e49e..a051fe3da9 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -3,6 +3,7 @@ module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -20,9 +21,6 @@ module advection_test_tracer use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -51,7 +49,7 @@ module advection_test_tracer real :: y_origin !< Parameters describing the test functions real :: y_width !< Parameters describing the test functions - integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -153,7 +151,7 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & flux_type=' ', implementation=' ', caller="register_advection_test_tracer") enddo @@ -337,9 +335,8 @@ subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,CS%ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index be7aa2b37e..55f061da20 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -3,6 +3,7 @@ module boundary_impulse_tracer ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -21,9 +22,6 @@ module boundary_impulse_tracer use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -43,7 +41,7 @@ module boundary_impulse_tracer 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? 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 aof_set_coupler_flux if it is used and the + 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 @@ -131,7 +129,7 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & flux_type=' ', implementation=' ', caller="register_boundary_impulse_tracer") enddo ! Register remaining source time as a restart field @@ -356,9 +354,8 @@ subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,CS%ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 48baddaab9..ccb1a3635b 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -3,6 +3,7 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -21,9 +22,6 @@ module regional_dyes use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -50,7 +48,7 @@ module regional_dyes 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? - integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -172,7 +170,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & flux_type=' ', implementation=' ', caller="register_dye_tracer") enddo @@ -395,9 +393,8 @@ subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,CS%ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index c54396eee6..eb49d0beef 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -3,6 +3,7 @@ module dyed_obc_tracer ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coupler_types, only : 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 @@ -19,9 +20,6 @@ module dyed_obc_tracer use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -38,7 +36,7 @@ module dyed_obc_tracer 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? - integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -122,7 +120,7 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & flux_type=' ', implementation=' ', caller="register_dyed_obc_tracer") enddo diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 6689cc5149..31d13c811e 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -3,6 +3,7 @@ module ideal_age_example ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -21,9 +22,6 @@ module ideal_age_example use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -56,7 +54,7 @@ module ideal_age_example !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. - integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -183,7 +181,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & flux_type=' ', implementation=' ', caller="register_ideal_age_tracer") enddo @@ -443,9 +441,8 @@ subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,CS%ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index ae2c71a87c..e73562dc1d 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -3,6 +3,7 @@ module oil_tracer ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -21,9 +22,6 @@ module oil_tracer use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -62,7 +60,7 @@ module oil_tracer integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code !! if they are not found in the restart files. - integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers @@ -190,7 +188,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & flux_type=' ', implementation=' ', caller="register_oil_tracer") enddo @@ -477,9 +475,8 @@ subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,CS%ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index df795d3119..9cb94a3054 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -23,9 +23,6 @@ module pseudo_salt_tracer use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index afb341ac16..395eec50c5 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -3,6 +3,7 @@ module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. +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 @@ -19,9 +20,6 @@ module USER_tracer_example use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use coupler_types_mod, only : coupler_type_set_data, ind_csurf -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux - implicit none ; private #include @@ -42,7 +40,7 @@ module USER_tracer_example real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. - integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + 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. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the timing of diagnostic output. @@ -126,7 +124,7 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! values to the coupler (if any). This is meta-code and its arguments will ! currently (deliberately) give fatal errors if it is used. if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(name)//'_flux', & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & flux_type=' ', implementation=' ', caller="USER_register_tracer_example") enddo @@ -428,9 +426,8 @@ subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) do m=1,ntr ! This call loads the surface values into the appropriate array in the ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) enddo endif From 73304ebf89ee15ce27e2b04debd77ba66232b047 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 24 Jan 2021 08:18:15 -0500 Subject: [PATCH 161/212] Eliminated mpp calls from coupled_driver Channel all infrastructure calls from coupled_driver via the MOM6 framework code. This includes changing the type of one of the arguments and eliminating another argument to initialize_ocean_public_type to pass a MOM_domain_type, and using clone_MOM_domain to create the domain2D element of the Ocean_sfc type. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 14 ++-- config_src/coupled_driver/ocean_model_MOM.F90 | 79 +++++++------------ 2 files changed, 33 insertions(+), 60 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 4d2d9dec9b..dd84f1692c 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -7,6 +7,9 @@ module MOM_surface_forcing_gfdl !#CTRL# use MOM_controlled_forcing, only : ctrl_forcing_CS use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type @@ -23,7 +26,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_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : slasher, write_version_number, MOM_read_data, stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -33,11 +36,7 @@ module MOM_surface_forcing_gfdl use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout implicit none ; private @@ -318,8 +317,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if ((.not.coupler_type_initialized(fluxes%tr_fluxes)) .and. & coupler_type_initialized(IOB%fluxes)) & - call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, & - (/is,is,ie,ie/), (/js,js,je,je/)) + call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, (/is,is,ie,ie/), (/js,js,je,je/)) ! It might prove valuable to use the same array extents as the rest of the ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) @@ -1628,7 +1626,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported integer :: n,m, outunit - outunit = stdout() + outunit = stdout write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep write(outunit,100) 'iobt%u_flux ', field_chksum( iobt%u_flux ) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 12f803a970..edb06dc9ba 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -17,10 +17,14 @@ module ocean_model_mod use MOM, only : get_ocean_stocks, step_offline 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 +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_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 +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 use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct @@ -31,7 +35,7 @@ module ocean_model_mod use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_io, only : close_file, file_exists, read_data, write_version_number, stdout 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 @@ -52,14 +56,6 @@ module ocean_model_mod use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, 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 atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use fms_mod, only : stdout #include @@ -107,7 +103,7 @@ module ocean_model_mod !! points of the two velocity components. Valid entries !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, !! corresponding to the community-standard Arakawa notation. - !! (These are named integers taken from mpp_parameter_mod.) + !! (These are named integers taken from the MOM_domains module.) !! Following MOM5, stagger is BGRID_NE by default when the !! ocean is initialized, but here it is set to -999 so that !! a global max across ocean and non-ocean processors can be @@ -391,14 +387,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call MOM_wave_interface_init_lite(param_file) endif - if (associated(OS%grid%Domain%maskmap)) then - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, maskmap=OS%grid%Domain%maskmap, & - gas_fields_ocn=gas_fields_ocn) - else - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, gas_fields_ocn=gas_fields_ocn) - endif + call initialize_ocean_public_type(OS%grid%Domain, Ocean_sfc, OS%diag, & + gas_fields_ocn=gas_fields_ocn) ! This call can only occur here if the coupler_bc_type variables have been ! initialized already using the information from gas_fields_ocn. @@ -513,8 +503,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) ! Translate Ice_ocean_boundary into fluxes and forces. - call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & - index_bnds(3), index_bnds(4)) + call get_domain_extent(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), index_bnds(3), index_bnds(4)) if (do_dyn) then call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time_dyn, OS%grid, OS%US, & @@ -733,7 +722,7 @@ end subroutine ocean_model_end subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state (in). - type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. + type(time_type), intent(in) :: Time !< The model time at this call, needed for writing files. character(len=*), optional, intent(in) :: directory !< An optional directory into which to !! write these restart files. character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) @@ -765,16 +754,12 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) end subroutine ocean_model_save_restart !> Initialize the public ocean type -subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & - gas_fields_ocn) - type(domain2D), intent(in) :: input_domain !< The ocean model domain description +subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_fields_ocn) + type(MOM_domain_type), intent(in) :: input_domain !< The ocean model domain description type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly - !! visible ocean surface properties after initialization, whose - !! elements are allocated here. - type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnsotic output - logical, dimension(:,:), & - optional, intent(in) :: maskmap !< A mask indicating which virtual processors - !! are actually in use. If missing, all are used. + !! visible ocean surface properties after + !! initialization, whose elements are allocated here. + type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnostic output type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -786,14 +771,9 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, ! and have no halos. integer :: isc, iec, jsc, jec - call mpp_get_layout(input_domain,layout) - call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) - else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) - endif - call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) + call clone_MOM_domain(input_domain, Ocean_sfc%Domain, halo_size=0, symmetric=.false.) + + call get_domain_extent(Ocean_sfc%Domain, isc, iec, jsc, jec) allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & Ocean_sfc%s_surf (isc:iec,jsc:jec), & @@ -849,8 +829,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call pass_vector(sfc_state%u, sfc_state%v, G%Domain) - call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) if (present(patm)) then ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). if (.not.present(press_to_z)) call MOM_error(FATAL, & @@ -1044,20 +1023,17 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + integer :: g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed, i, j if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + ! The problem is that %areaT is on MOM domain but Ice_Ocean_Boundary%... is on a haloless domain. + ! We want to return the MOM data on the haloless (compute) domain + call get_domain_extent(OS%grid%Domain, g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed) g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - select case(name) case('area') array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) @@ -1127,7 +1103,7 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) !! visible ocean surface fields. integer :: n, m, outunit - outunit = stdout() + outunit = stdout write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep write(outunit,100) 'ocean%t_surf ', field_chksum(ocn%t_surf ) @@ -1180,8 +1156,7 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) G => OS%grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call mpp_get_compute_domain(Ocean%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) + call get_domain_extent(Ocean%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) i0 = is - isc_bnd ; j0 = js - jsc_bnd From a54f47a6f3683c9d4c6332fa0be7a697dd3d5da5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 24 Jan 2021 13:13:14 -0500 Subject: [PATCH 162/212] +Eliminated fms calls from solo_driver Channel all infrastructure calls from solo_driver via the MOM6 framework code. This includes adding 2 more interfaces to MOM_ensemble_manager and making the affinity routines to those that are publicly accessible from MOM_domains. Several spelling errors in comments were also corrected. All answers are bitwise identical, but some subroutines are accessible from new modules. --- config_src/solo_driver/MOM_driver.F90 | 39 +++++++++----------------- src/framework/MOM_domain_infra.F90 | 19 +++++++------ src/framework/MOM_domains.F90 | 5 ++-- src/framework/MOM_ensemble_manager.F90 | 6 +++- 4 files changed, 33 insertions(+), 36 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index c9383a4287..584282f27f 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -33,15 +33,20 @@ program MOM_main use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : step_offline use MOM_coms, only : Set_PElist - use MOM_domains, only : MOM_infra_init, MOM_infra_end + 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 + use MOM_ensemble_manager, only : ensemble_pelist_setup use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_file_parser, only : close_param_file use MOM_forcing_type, only : forcing, mech_forcing, forcing_diagnostics use MOM_forcing_type, only : mech_forcing_diags, MOM_forcing_chksum, MOM_mech_forcing_chksum - use MOM_get_input, only : directories + use MOM_get_input, only : get_MOM_input, directories use MOM_grid, only : ocean_grid_type + use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS + 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_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -50,30 +55,19 @@ program MOM_main 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 - use MOM_time_manager, only : time_type, set_date, get_date - use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_type_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type + use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init + use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves 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_get_input, only : get_MOM_input - use ensemble_manager_mod, only : ensemble_manager_init, get_ensemble_size - use ensemble_manager_mod, only : ensemble_pelist_setup - use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get - - use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - 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_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init - use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves implicit none @@ -253,13 +247,8 @@ program MOM_main endif endif -!$ call fms_affinity_init -!$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) -!$ call omp_set_num_threads(ocean_nthreads) -!$OMP PARALLEL -!$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() -!$ flush(6) -!$OMP END PARALLEL + ! This call sets the number and affinity of threads with openMP. + !$ call set_MOM_thread_affinity(ocean_nthreads, use_hyper_thread) ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then @@ -337,7 +326,7 @@ program MOM_main call callTree_waypoint("done surface_forcing_init") - call get_param(param_file,mod_name,"USE_WAVES",Use_Waves,& + call get_param(param_file,mod_name, "USE_WAVES", Use_Waves, & "If true, enables surface wave modules.",default=.false.) if (use_waves) then call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 5ced2e33c0..1f0594ef0d 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -498,7 +498,7 @@ subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, h end subroutine pass_var_complete_3d !> pass_vector_2d does a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. +!! representing the components of a two-dimensional horizontal vector. subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & clock) real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector @@ -557,7 +557,7 @@ end subroutine pass_vector_2d !> fill_vector_symmetric_edges_2d does an usual set of halo updates that only !! fill in the values at the edge of a pair of symmetric memory two-dimensional -!! arrays representing the compontents of a two-dimensional horizontal vector. +!! arrays representing the components of a two-dimensional horizontal vector. !! If symmetric memory is not being used, this subroutine does nothing except to !! possibly turn optional cpu clocks on or off. subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & @@ -644,7 +644,7 @@ subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scal end subroutine fill_vector_symmetric_edges_2d !> pass_vector_3d does a halo update for a pair of three-dimensional arrays -!! representing the compontents of a three-dimensional horizontal vector. +!! representing the components of a three-dimensional horizontal vector. subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & clock) real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector @@ -702,7 +702,7 @@ subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, end subroutine pass_vector_3d !> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. +!! representing the components of a two-dimensional horizontal vector. function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & clock) real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector @@ -759,7 +759,7 @@ function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, compl end function pass_vector_start_2d !> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays -!! representing the compontents of a three-dimensional horizontal vector. +!! representing the components of a three-dimensional horizontal vector. function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & clock) real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector @@ -815,7 +815,7 @@ function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, compl end function pass_vector_start_3d !> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays -!! representing the compontents of a two-dimensional horizontal vector. +!! representing the components of a two-dimensional horizontal vector. subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & clock) integer, intent(in) :: id_update !< The integer id of this update which has been @@ -869,7 +869,7 @@ subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction end subroutine pass_vector_complete_2d !> pass_vector_complete_3d completes a halo update for a pair of three-dimensional -!! arrays representing the compontents of a three-dimensional horizontal vector. +!! arrays representing the components of a three-dimensional horizontal vector. subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & clock) integer, intent(in) :: id_update !< The integer id of this update which has been @@ -1371,7 +1371,7 @@ function MOM_thread_affinity_set() !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) end function MOM_thread_affinity_set -!> set_MOM_thread_affinity sest the number of openMP threads to use with the ocean. +!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean. subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading @@ -1379,10 +1379,13 @@ subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) ! Local variables !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + !$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once. !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) + !$OMP PARALLEL !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ flush(6) + !$OMP END PARALLEL end subroutine set_MOM_thread_affinity !> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 9ccef2888e..d230ecdf74 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -32,6 +32,7 @@ module MOM_domains ! Domain types and creation and destruction routines public :: MOM_domain_type, domain2D, domain1D public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! Domain query routines public :: get_domain_extent, get_domain_components, compute_block_extent, get_global_shape public :: PE_here, root_PE, num_PEs @@ -52,7 +53,7 @@ module MOM_domains contains !> 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' +!! 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, & NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & @@ -260,7 +261,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & min_halo(1) = n_halo(1) n_halo(2) = max(n_halo(2), min_halo(2)) min_halo(2) = n_halo(2) - ! These are generally used only with static memory, so they are considerd layout params. + ! These are generally used only with static memory, so they are considered layout params. call log_param(param_file, mdl, "!NIHALO min_halo", n_halo(1), layoutParam=.true.) call log_param(param_file, mdl, "!NJHALO min_halo", n_halo(2), layoutParam=.true.) endif diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90 index 191dd79c9a..df1c30fc74 100644 --- a/src/framework/MOM_ensemble_manager.F90 +++ b/src/framework/MOM_ensemble_manager.F90 @@ -3,12 +3,16 @@ module MOM_ensemble_manager ! This file is part of MOM6. See LICENSE.md for the license. +use ensemble_manager_mod, only : ensemble_manager_init, ensemble_pelist_setup use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist implicit none ; private -public get_ensemble_id, get_ensemble_size, get_ensemble_pelist, get_ensemble_filter_pelist +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist +! There need to be documented APIs in this module. end module MOM_ensemble_manager From 1eb56768859a840b363d8e2cd1a5eca955b67eb0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 25 Jan 2021 11:02:09 -0500 Subject: [PATCH 163/212] Autoconf: 2.70 macro update The MPI configuration macro was updated to replace the deprecated AC_TRY_COMPILE macros. --- ac/deps/m4/ax_mpi.m4 | 8 ++++---- ac/m4/ax_mpi.m4 | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/ac/deps/m4/ax_mpi.m4 b/ac/deps/m4/ax_mpi.m4 index ecce2e141a..3d9966a19d 100644 --- a/ac/deps/m4/ax_mpi.m4 +++ b/ac/deps/m4/ax_mpi.m4 @@ -67,7 +67,7 @@ AU_ALIAS([ACX_MPI], [AX_MPI]) AC_DEFUN([AX_MPI], [ -AC_PREREQ(2.50) dnl for AC_LANG_CASE +AC_PREREQ([2.50]) dnl for AC_LANG_CASE AC_LANG_CASE([C], [ AC_REQUIRE([AC_PROG_CC]) @@ -135,16 +135,16 @@ if test x = x"$MPILIBS"; then AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) fi -dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl We have to use AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[],[]) and not AC_CHECK_HEADER because the dnl latter uses $CPP, not $CC (which may be mpicc). AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" AC_MSG_RESULT(no)]) fi], [C++], [if test x != x"$MPILIBS"; then AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" AC_MSG_RESULT(no)]) fi], [Fortran 77], [if test x != x"$MPILIBS"; then diff --git a/ac/m4/ax_mpi.m4 b/ac/m4/ax_mpi.m4 index ecce2e141a..3d9966a19d 100644 --- a/ac/m4/ax_mpi.m4 +++ b/ac/m4/ax_mpi.m4 @@ -67,7 +67,7 @@ AU_ALIAS([ACX_MPI], [AX_MPI]) AC_DEFUN([AX_MPI], [ -AC_PREREQ(2.50) dnl for AC_LANG_CASE +AC_PREREQ([2.50]) dnl for AC_LANG_CASE AC_LANG_CASE([C], [ AC_REQUIRE([AC_PROG_CC]) @@ -135,16 +135,16 @@ if test x = x"$MPILIBS"; then AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) fi -dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl We have to use AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[],[]) and not AC_CHECK_HEADER because the dnl latter uses $CPP, not $CC (which may be mpicc). AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" AC_MSG_RESULT(no)]) fi], [C++], [if test x != x"$MPILIBS"; then AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" AC_MSG_RESULT(no)]) fi], [Fortran 77], [if test x != x"$MPILIBS"; then From 94e1277e665771b661b6035a91693a9644d4875b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 25 Jan 2021 11:20:52 -0500 Subject: [PATCH 164/212] Autoconf: Revert FMS version Revert the target FMS for ac/deps/fms (and .testing) until the FMS2 transition issues have been resolved. --- ac/deps/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ac/deps/Makefile b/ac/deps/Makefile index bba42a3b11..0ed4fd19a7 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -13,7 +13,7 @@ MKMF_COMMIT ?= master # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2020.04 +FMS_COMMIT ?= 2019.01.03 # List of source files to link this Makefile's dependencies to model Makefiles From 6712015b710865ab94a82c898c5146d10d4eaa6c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 25 Jan 2021 17:13:01 -0500 Subject: [PATCH 165/212] +Added 7 thin wrapper routines to MOM_io_infra.F90 Added explicitly documented interfaces to close_file, flux_file, io_infra_init, io_infra_end, get_file_info, get_file_fields, and get_field_atts to MOM_io_infra.F90. Also changed from get_file_atts to get_field_atts for the routine that is available via MOM_io.F90 and used in MOM_restart, since this name captures the use of this call and reflects which of the underlying routines the overloaded interface mpp_get_atts resolves to. All answers are bitwise identical, but there is a localized interface name change, and not all of the optional arguments in the underlying FMS or mpp routines are being made available for use with MOM6 code. --- src/framework/MOM_io.F90 | 4 +- src/framework/MOM_io_infra.F90 | 96 +++++++++++++++++++++++++++++----- src/framework/MOM_restart.F90 | 8 +-- 3 files changed, 89 insertions(+), 19 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 2a547dbdd1..9c0cb3a228 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -11,7 +11,7 @@ module MOM_io use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io_infra, only : MOM_read_data, read_data, MOM_read_vector, read_field_chksum -use MOM_io_infra, only : file_exists, get_file_info, get_file_atts, get_file_fields +use MOM_io_infra, only : file_exists, get_file_info, get_file_fields, get_field_atts use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, field_exists use MOM_io_infra, only : flush_file, get_filename_appendix, get_ensemble_id use MOM_io_infra, only : get_file_times, axistype, get_axis_data @@ -35,7 +35,7 @@ module MOM_io public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc ! The following are simple pass throughs of routines from MOM_io_infra or other modules public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix -public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields +public :: file_exists, flush_file, get_file_info, get_file_fields, get_field_atts public :: get_file_times, open_file, get_axis_data public :: MOM_read_data, MOM_read_vector, read_data, read_field_chksum public :: slasher, write_field, write_version_number diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index a854cd6d2a..1a075b63ef 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -5,38 +5,39 @@ module MOM_io_infra use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING use ensemble_manager_mod, only : get_ensemble_id use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data -use fms_io_mod, only : io_infra_end=>fms_io_exit, get_filename_appendix -use mpp_domains_mod, only : domain2d, CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST -use mpp_io_mod, only : mpp_open, close_file=>mpp_close +use fms_io_mod, only : fms_io_exit, get_filename_appendix +use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush use mpp_io_mod, only : write_metadata=>mpp_write_meta, mpp_write -use mpp_io_mod, only : get_field_atts=>mpp_get_atts, mpp_attribute_exist +use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, get_axis_data=>mpp_get_axis_data -use mpp_io_mod, only : mpp_get_fields, fieldtype, flush_file=>mpp_flush +use mpp_io_mod, only : mpp_get_fields, fieldtype +use mpp_io_mod, only : mpp_get_info +use mpp_io_mod, only : get_file_times=>mpp_get_times +use mpp_io_mod, only : mpp_io_init +! These are encoding constants. use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY use mpp_io_mod, only : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY -use mpp_io_mod, only : get_file_info=>mpp_get_info, get_file_atts=>mpp_get_atts -use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times -use mpp_io_mod, only : io_infra_init=>mpp_io_init implicit none ; private ! These interfaces are actually implemented or have explicit interfaces in this file. -public :: MOM_read_data, MOM_read_vector, write_field, open_file +public :: MOM_read_data, MOM_read_vector, write_field, open_file, close_file, flush_file public :: file_exists, field_exists, read_field_chksum +public :: get_file_info, get_file_fields, get_field_atts, io_infra_init, io_infra_end ! The following are simple pass throughs of routines from other modules. They need ! to have explicit interfaces added to this file. -public :: close_file, field_size, fieldtype, get_filename_appendix -public :: flush_file, get_file_info, get_file_atts, get_file_fields, get_field_atts -public :: get_file_times, read_data, axistype, get_axis_data +public :: fieldtype, axistype, field_size, get_filename_appendix +public :: get_file_times, read_data, get_axis_data public :: write_metadata, write_version_number, get_ensemble_id -public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end +public :: open_namelist_file, check_nml_error ! These are encoding constants. public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE @@ -122,6 +123,34 @@ function FMS_file_exists(filename, domain, no_domain) end function FMS_file_exists +!> close_file closes a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +subroutine close_file(unit) + integer, intent(out) :: unit !< The I/O unit for the file to be closed + + call mpp_close(unit) +end subroutine close_file + +!> Ensure that the output stream associated with a unit is fully sent to dis. +subroutine flush_file(unit) + integer, intent(out) :: unit !< The I/O unit for the file to flush + + call mpp_flush(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) +end subroutine io_infra_init + +!> Gracefully close out and terminate the underlying I/O infrastructure +subroutine io_infra_end() + call fms_io_exit() +end subroutine io_infra_end + + !> open_file opens a file for parallel or single-file I/O. subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domain, MOM_domain) integer, intent(out) :: unit !< The I/O unit for the opened file @@ -150,6 +179,47 @@ subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domai endif end subroutine open_file +!> Get information about the number of dimensions, variables, global attributes and time levels +!! in the file associated with an open file unit +subroutine get_file_info(unit, ndim, nvar, natt, ntime) + integer, intent(in) :: unit !< The I/O unit for the open file + 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) :: natt !< The number of global attributes in the file + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + ! Local variables + integer :: ndims, nvars, natts, ntimes + + call mpp_get_info( unit, ndims, nvars, natts, ntimes ) + + if (present(ndim)) ndim = ndims + if (present(nvar)) nvar = nvars + if (present(natt)) natt = natts + if (present(ntime)) ntime = ntimes + +end subroutine get_file_info + +!> Set up the field information (e.g., names and metadata) for all of the variables in a file. The +!! argument fields must be allocated with a size that matches the number of variables in a file. +subroutine get_file_fields(unit, fields) + integer, intent(in) :: unit !< The I/O unit for the open file + type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of + !! the variables in a file. + call mpp_get_fields(unit, fields) +end subroutine get_file_fields + +!> Extract information from a field type, as stored or as found in a file +subroutine get_field_atts(field, name, units, longname, checksum) + type(fieldtype), 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=8), dimension(:), & + optional, intent(out) :: checksum !< The checksums of the variable in a file + call mpp_get_atts(field, name=name, units=units, longname=longname, checksum=checksum) +end subroutine get_field_atts + !> Field_exists returns true if the field indicated by field_name is present in the !! file file_name. If file_name does not exist, it returns false. function field_exists(filename, field_name, domain, no_domain, MOM_domain) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 73a41c5aa5..6780eff644 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -10,7 +10,7 @@ module MOM_restart use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file use MOM_io, only : MOM_read_data, read_data, MOM_write_field, read_field_chksum -use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times +use MOM_io, only : get_file_info, get_file_fields, get_field_atts, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -1160,10 +1160,10 @@ subroutine restore_state(filename, directory, day, G, CS) call get_file_info(unit(n), ndim, nvar, natt, ntime) allocate(fields(nvar)) - call get_file_fields(unit(n),fields(1:nvar)) + call get_file_fields(unit(n), fields(1:nvar)) do m=1, nvar - call get_file_atts(fields(m),name=varname) + call 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 "//& @@ -1194,7 +1194,7 @@ 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_file_atts(fields(i),name=varname) + call 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 From 83fa9ce93a62d21745ee1fe66a0935170950ae08 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jan 2021 10:29:58 -0500 Subject: [PATCH 166/212] Replace pass troughs of mpp entities MOM_cpu_clock was making public several entities (functions and parameters) belonging to MPP. - This commit either wraps functions are creates new parameters. - Also adds documentation for all new wrapping functions and parameters. --- src/framework/MOM_cpu_clock.F90 | 67 ++++++++++++++++++++++++++++----- 1 file changed, 58 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index a041b06b8b..78d5f20c97 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -3,23 +3,73 @@ module MOM_cpu_clock ! This file is part of MOM6. See LICENSE.md for the license. +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module use fms_mod, only : clock_flag_default -use mpp_mod, only : cpu_clock_begin => mpp_clock_begin -use mpp_mod, only : cpu_clock_end => mpp_clock_end, mpp_clock_id -use mpp_mod, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER -use mpp_mod, only : CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA -use mpp_mod, only : CLOCK_SYNC => MPP_CLOCK_SYNC +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA implicit none ; private +! Public entities public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE -public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA, CLOCK_SYNC +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA contains -!> cpu_clock_id returns the integer handle for a named CPU clock. -function cpu_clock_id( name, synchro_flag, grain ) +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id( name, synchro_flag, grain ) character(len=*), intent(in) :: name !< The unique name of the CPU clock integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs !! are synchronized before the cpu clocks start counting. @@ -29,7 +79,6 @@ function cpu_clock_id( name, synchro_flag, grain ) !! settings for FMS. integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. - integer :: cpu_clock_id !< The integer CPU clock handle. if (present(synchro_flag)) then cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) From 84a90053d0349ddffb53ad669e58615839c55d20 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jan 2021 10:41:15 -0500 Subject: [PATCH 167/212] Inserts layer between wrapper for cpu-clocks Since MOM code will not be allowed to directly reference the wrapper layer around infrastructure this adds a layer that will remain in framework. - Renamed MOM_cpu_clock.F90 to MOM_cpu_clock_infra.F90 . This module defines the API to clocks and any new wrappers must map between this and any alternate infrastructure clocks. - Created new module MOM_cpu_clock.F90 which simply has pass throughs since no added "MOM-only" functinoality need be added. --- src/framework/MOM_cpu_clock.F90 | 88 ++++---------------------- src/framework/MOM_cpu_clock_infra.F90 | 91 +++++++++++++++++++++++++++ 2 files changed, 102 insertions(+), 77 deletions(-) create mode 100644 src/framework/MOM_cpu_clock_infra.F90 diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index 78d5f20c97..de0bb46307 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -1,19 +1,19 @@ -!> Wraps the MPP cpu clock functions +!> Provides cpu clock functions module MOM_cpu_clock ! This file is part of MOM6. See LICENSE.md for the license. ! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module -use fms_mod, only : clock_flag_default -use mpp_mod, only : mpp_clock_begin -use mpp_mod, only : mpp_clock_end, mpp_clock_id -use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT -use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT -use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER -use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE -use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE -use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP -use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA +use MOM_cpu_clock_infra, only : cpu_clock_begin +use MOM_cpu_clock_infra, only : cpu_clock_end +use MOM_cpu_clock_infra, only : cpu_clock_id +use MOM_cpu_clock_infra, only : CLOCK_COMPONENT +use MOM_cpu_clock_infra, only : CLOCK_SUBCOMPONENT +use MOM_cpu_clock_infra, only : CLOCK_MODULE_DRIVER +use MOM_cpu_clock_infra, only : CLOCK_MODULE +use MOM_cpu_clock_infra, only : CLOCK_ROUTINE +use MOM_cpu_clock_infra, only : CLOCK_LOOP +use MOM_cpu_clock_infra, only : CLOCK_INFRA implicit none ; private @@ -22,70 +22,4 @@ module MOM_cpu_clock public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! component, e.g. the entire MOM6 model -integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! sub-component, e.g. dynamics or thermodynamics -integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! module driver, e.g. a routine that calls multiple other routines -integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! module, e.g. the main entry routine for a module -integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! subroutine or function -integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a -!! section with in a routine, e.g. around a loop -integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP - -!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an -!! infrastructure operation, e.g. a halo update -integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA - -contains - -!> Turns on clock with handle "id" -subroutine cpu_clock_begin(id) - integer, intent(in) :: id !< Handle for clock - - call mpp_clock_begin(id) - -end subroutine cpu_clock_begin - -!> Turns off clock with handle "id" -subroutine cpu_clock_end(id) - integer, intent(in) :: id !< Handle for clock - - call mpp_clock_end(id) - -end subroutine cpu_clock_end - -!> Returns the integer handle for a named CPU clock. -integer function cpu_clock_id( name, synchro_flag, grain ) - character(len=*), intent(in) :: name !< The unique name of the CPU clock - integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs - !! are synchronized before the cpu clocks start counting. - !! Synchronization occurs before the start of a clock if this - !! is odd, while additional (expensive) statistics can set - !! for other values. If absent, the default is taken from the - !! settings for FMS. - integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to - !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. - - if (present(synchro_flag)) then - cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) - else - cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) - endif - -end function cpu_clock_id - end module MOM_cpu_clock diff --git a/src/framework/MOM_cpu_clock_infra.F90 b/src/framework/MOM_cpu_clock_infra.F90 new file mode 100644 index 0000000000..46d9c04f02 --- /dev/null +++ b/src/framework/MOM_cpu_clock_infra.F90 @@ -0,0 +1,91 @@ +!> Wraps the MPP cpu clock functions +module MOM_cpu_clock_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use fms_mod, only : clock_flag_default +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA + +implicit none ; private + +! Public entities +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA + +contains + +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id( name, synchro_flag, grain ) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs + !! are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is odd, while additional (expensive) statistics can set + !! for other values. If absent, the default is taken from the + !! settings for FMS. + integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + + if (present(synchro_flag)) then + cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) + else + cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) + endif + +end function cpu_clock_id + +end module MOM_cpu_clock_infra From 7f69add603945e600ab2f27c11bfd49cb979aa9b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jan 2021 13:33:36 -0500 Subject: [PATCH 168/212] Adds doxygen cross-references for MOM_cpu_clock --- src/framework/MOM_cpu_clock.F90 | 13 ++++++++++++- src/framework/MOM_cpu_clock_infra.F90 | 2 ++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index de0bb46307..f4e605a06c 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -17,9 +17,20 @@ module MOM_cpu_clock implicit none ; private -! Public entities +!> Public functions: +!> mom_cpu_clock_infra::cpu_clock_id, mom_cpu_clock_infra::cpu_clock_begin, mom_cpu_clock_infra::cpu_clock_end public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end + +!> Public constants: +!> mom_cpu_clock_infra::clock_component, mom_cpu_clock_infra::clock_subcomponent +!> mom_cpu_clock_infra::clock_module_driver, mom_cpu_clock_infra::clock_module_driver public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +!> mom_cpu_clock_infra::clock_routine, mom_cpu_clock_infra::clock_loop +!> mom_cpu_clock_infra::clock_infra public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA end module MOM_cpu_clock + +!> \namespace mom_cpu_clock +!! +!! APIs are defined and implemented in mom_cpu_clock_infra. diff --git a/src/framework/MOM_cpu_clock_infra.F90 b/src/framework/MOM_cpu_clock_infra.F90 index 46d9c04f02..f0a4a71ae5 100644 --- a/src/framework/MOM_cpu_clock_infra.F90 +++ b/src/framework/MOM_cpu_clock_infra.F90 @@ -1,4 +1,6 @@ !> Wraps the MPP cpu clock functions +!! +!! The functions and constants should be accessed via mom_cpu_clock module MOM_cpu_clock_infra ! This file is part of MOM6. See LICENSE.md for the license. From 797b195862e8a99e2b16f6b7a8620640aaf38531 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 26 Jan 2021 16:46:40 -0500 Subject: [PATCH 169/212] Explicit interfaces for MOM_coms_infra FMS pass-through functions were redefined as explicit functions, primarily to provide documentation but perhaps also just as an additional layer of configuration in the future. --- src/framework/MOM_coms_infra.F90 | 283 ++++++++++++++++++++++++++++++- 1 file changed, 274 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_coms_infra.F90 b/src/framework/MOM_coms_infra.F90 index f187d010a4..fb4a3cd6ea 100644 --- a/src/framework/MOM_coms_infra.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -3,20 +3,23 @@ module MOM_coms_infra ! This file is part of MOM6. See LICENSE.md for the license. -use fms_mod, only : fms_end, MOM_infra_init => fms_init +use iso_fortran_env, only : int32, int64 + +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe +use mpp_mod, only : mpp_set_current_pelist, mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_chksum +use mpp_mod, only : mpp_sum, mpp_max, mpp_min use memutils_mod, only : print_memuse_stats -use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes -use mpp_mod, only : set_rootPE => mpp_set_root_pe -use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist -use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, field_chksum => mpp_chksum -use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min +use fms_mod, only : fms_end, fms_init implicit none ; private -public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end, Set_PElist, Get_PElist -public :: set_rootPE, broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: field_chksum, MOM_infra_init, MOM_infra_end -! This module provides interfaces to the non-domain-oriented communication subroutines. +! This module provides interfaces to the non-domain-oriented communication +! subroutines. !> Communicate an array, string or scalar from one PE to others interface broadcast @@ -24,8 +27,81 @@ module MOM_coms_infra module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D end interface broadcast +interface field_chksum + module procedure field_chksum_real_0d + module procedure field_chksum_real_1d + module procedure field_chksum_real_2d + module procedure field_chksum_real_3d + module procedure field_chksum_real_4d +end interface field_chksum + +interface sum_across_PEs + module procedure sum_across_PEs_int4_0d + module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int8_0d + module procedure sum_across_PEs_int8_1d + module procedure sum_across_PEs_int8_2d + module procedure sum_across_PEs_real_0d + module procedure sum_across_PEs_real_1d + module procedure sum_across_PEs_real_2d +end interface sum_across_PEs + +interface max_across_PEs + module procedure max_across_PEs_int_0d + module procedure max_across_PEs_real_0d + module procedure max_across_PEs_real_1d +end interface max_across_PEs + +interface min_across_PEs + module procedure min_across_PEs_int_0d + module procedure min_across_PEs_real_0d + module procedure min_across_PEs_real_1d +end interface min_across_PEs + contains +!> Retuen the ID of the PE for the current process. +function PE_here() result(pe) + integer :: pe !< PE ID of the current process + pe = mpp_pe() +end function PE_here + +!> Return the ID of the root PE for the PE list of the current procss. +function root_PE() result(pe) + integer :: pe !< root PE ID + pe = mpp_root_pe() +end function root_PE + +!> Return the number of PEs for the current PE list. +function num_PEs() result(npes) + integer :: npes !< Number of PEs + npes = mpp_npes() +end function num_PEs + +!> Designate a PE as the root PE +subroutine set_rootPE(pe) + integer, intent(in) :: pe !< ID of the PE to be assigned as root + call mpp_set_root_pe(pe) +end subroutine + +!> Set the current PE list. If no list is provided, then the current PE list +!! is set to the list of all available PEs on the communicator. Setting the +!! list will trigger a rank synchronization unless the `no_sync` flag is set. +subroutine Set_PEList(pelist, no_sync) + integer, intent(in), optional :: pelist(:) !< List of + logical, intent(in), optional :: no_sync !< Do not sync after list update. + call mpp_set_current_pelist(pelist, no_sync) +end subroutine Set_PEList + +!> Retrieve the current PE list and any metadata if requested. +subroutine Get_PEList(pelist, name, commID) + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), intent(out), optional :: name !< Name of PE list + integer, intent(out), optional :: commID !< Communicator ID of PE list + + call mpp_get_current_pelist(pelist, name, commiD) +end subroutine Get_PEList + !> Communicate a 1-D array of character strings from one PE to others subroutine broadcast_char(dat, length, from_PE, PElist, blocking) character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination @@ -150,6 +226,195 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D +! field_chksum wrappers + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_0d(field, pelist, mask_val) result(chksum) + real, intent(in) :: field !< Input scalar + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_0d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_1d(field, pelist, mask_val) result(chksum) + real, dimension(:), intent(in) :: field !< Input array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_1d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_2d(field, pelist, mask_val) result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_2d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_3d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_3d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_4d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_4d + +! sum_across_PEs wrappers + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_int4_0d(field, pelist) + integer(kind=int32), intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int4_0d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_int4_1d(field, length, pelist) + integer(kind=int32), dimension(:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_1d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_int8_0d(field, pelist) + integer(kind=int64), intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int8_0d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_int8_1d(field, length, pelist) + integer(kind=int64), dimension(:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_1d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_int8_2d(field, length, pelist) + integer(kind=int64), dimension(:,:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_2d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_real_0d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_1d + +!> Find the sum of field across PEs, and update PEs with the sums. +subroutine sum_across_PEs_real_2d(field, length, pelist) + real, dimension(:,:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_2d + +! max_across_PEs wrappers + +!> Find the maximum value of field across PEs, and update PEs with the values. +subroutine max_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_max(field, pelist) +end subroutine max_across_PEs_int_0d + +!> Find the maximum value of field across PEs, and update PEs with the values. +subroutine max_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_max(field, pelist) +end subroutine max_across_PEs_real_0d + +!> Find the maximum value of field across PEs, and update PEs with the values. +subroutine max_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_max(field, length, pelist) +end subroutine max_across_PEs_real_1d + +! min_across_PEs wrappers + +!> Find the minimum value of field across PEs, and update PEs with the values. +subroutine min_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_min(field, pelist) +end subroutine min_across_PEs_int_0d + +!> Find the minimum value of field across PEs, and update PEs with the values. +subroutine min_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Input field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_min(field, pelist) +end subroutine min_across_PEs_real_0d + +!> Find the minimum value of field across PEs, and update PEs with the values. +subroutine min_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< Input field + integer, intent(in) :: length !< Length of field + integer, intent(in), optional :: pelist(:) !< PE list + + call mpp_min(field, length, pelist) +end subroutine min_across_PEs_real_1d + +!> Initialize the model framework, including PE communication over a designated +!! communicator. If no communicator ID is provided, then the framework's +!! default communicator is used. +subroutine MOM_infra_init(localcomm) + integer, intent(in), optional :: localcomm !< Communicator ID to initialize + call fms_init(localcomm) +end subroutine !> This subroutine carries out all of the calls required to close out the infrastructure cleanly. !! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. From c7070f7304bf3e9841f3cd24e6ffea22b8d6076d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 26 Jan 2021 16:53:41 -0500 Subject: [PATCH 170/212] MOM_coms_infra: Documentation update --- src/framework/MOM_coms_infra.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_coms_infra.F90 b/src/framework/MOM_coms_infra.F90 index fb4a3cd6ea..f83785dd7b 100644 --- a/src/framework/MOM_coms_infra.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -27,6 +27,8 @@ module MOM_coms_infra module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D end interface broadcast +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. interface field_chksum module procedure field_chksum_real_0d module procedure field_chksum_real_1d @@ -35,6 +37,7 @@ module MOM_coms_infra module procedure field_chksum_real_4d end interface field_chksum +!> Find the sum of field across PEs, and update PEs with the sums. interface sum_across_PEs module procedure sum_across_PEs_int4_0d module procedure sum_across_PEs_int4_1d @@ -46,12 +49,14 @@ module MOM_coms_infra module procedure sum_across_PEs_real_2d end interface sum_across_PEs +!> Find the maximum value of field across PEs, and update PEs with the values. interface max_across_PEs module procedure max_across_PEs_int_0d module procedure max_across_PEs_real_0d module procedure max_across_PEs_real_1d end interface max_across_PEs +!> Find the minimum value of field across PEs, and update PEs with the values. interface min_across_PEs module procedure min_across_PEs_int_0d module procedure min_across_PEs_real_0d @@ -60,7 +65,7 @@ module MOM_coms_infra contains -!> Retuen the ID of the PE for the current process. +!> Return the ID of the PE for the current process. function PE_here() result(pe) integer :: pe !< PE ID of the current process pe = mpp_pe() From c59c1d5e3925ab5a19763d85554c774426a92010 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jan 2021 18:11:52 -0500 Subject: [PATCH 171/212] Disconnect MOM_random from FMS/random The random number generator is not really infrastructure code but was shared code. Since we are trying to make MOM6 agnostic to the infrastructure it seemed simplest to copy the subset of the Mersenne Twister code we use into MOM_random. Moving forward we are expecting a state-free random number generater that will eventually displace the Mersenne Twister. --- src/framework/MOM_random.F90 | 129 ++++++++++++++++++++++++++++++++--- 1 file changed, 120 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 21e3223a03..09cb23056d 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -3,15 +3,10 @@ module MOM_random ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_hor_index, only : hor_index_type -use MOM_time_manager, only : time_type, set_date, get_date +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, set_date, get_date -use MersenneTwister_mod, only : randomNumberSequence ! Random number class from FMS -use MersenneTwister_mod, only : new_RandomNumberSequence ! Constructor/initializer -use MersenneTwister_mod, only : getRandomReal ! Generates a random number -use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer - -use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -23,6 +18,22 @@ module MOM_random public :: random_2d_norm public :: random_unit_tests +! Private period parameters for the Mersenne Twister +integer, parameter :: blockSize = 624, & !< Size of the state vector + M = 397, & !< Pivot element in state vector + MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) + UMASK = -2147483648_8, & !< most significant w-r bits (0x80000000UL) + LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) +! Private tempering parameters for the Mersenne Twister +integer, parameter :: TMASKB= -1658038656, & !< (0x9d2c5680UL) + TMASKC= -272236544 !< (0xefc60000UL) + +!> A private type used by the Mersenne Twistor +type randomNumberSequence + integer :: currentElement !< Index into state vector + integer, dimension(0:blockSize -1) :: state !< State vector +end type randomNumberSequence + !> Container for pseudo-random number generators type, public :: PRNG ; private @@ -177,6 +188,102 @@ subroutine random_destruct(CS) !deallocate(CS) end subroutine random_destruct +!> Return an initialized twister using seed +!! +!! Code was based on initialize_scaler() from the FMS implementation of the Mersenne Twistor +function new_RandomNumberSequence(seed) result(twister) + integer, intent(in) :: seed !< Seed to initialize twister + type(randomNumberSequence) :: twister !< The Mersenne Twister container + ! Local variables + integer :: i + + twister%state(0) = iand(seed, -1) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253 * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30)) + i + twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines + end do + twister%currentElement = blockSize +end function new_RandomNumberSequence + +!> Return a random integer on interval [0,0xffffffff] +!! +!! Code was based on getRandomInt() from the FMS implementation of the Mersenne Twistor +integer function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister !< The Mersenne Twister container + + if(twister%currentElement >= blockSize) call nextState(twister) + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + +end function getRandomInt + +!> Return a random real number on interval [0,1] +!! +!! Code was based on getRandomReal() from the FMS implementation of the Mersenne Twistor +double precision function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister + ! Local variables + integer :: localInt + + localInt = getRandomInt(twister) + if(localInt < 0) then + getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + else + getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + end if +end function getRandomReal + +!> Merge bits of u and v +integer function mixbits(u, v) + integer, intent(in) :: u !< An integer + integer, intent(in) :: v !< An integer + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) +end function mixbits + +!> Twist bits of u and v +integer function twist(u, v) + integer, intent(in) :: u !< An integer + integer, intent(in) :: v !< An integer + ! Local variable + integer, parameter, dimension(0:1) :: t_matrix = (/ 0, MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) + twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) +end function twist + +!> Update internal state of twister to the next state in the sequence +subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister !< Container for the Mersenne Twister + ! Local variables + integer :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1))) + end do + twister%state(blockSize - 1) = ieor(twister%state(M - 1), & + twist(twister%state(blockSize - 1), twister%state(0))) + twister%currentElement = 0 +end subroutine nextState + +!> Tempering of bits in y +elemental integer function temper(y) + integer, intent(in) :: y !< An integer + ! Local variables + integer :: x + + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) +end function temper + !> Runs some statistical tests on the PRNG logical function random_unit_tests(verbose) logical :: verbose !< True if results should be written to stdout @@ -439,7 +546,11 @@ end module MOM_random !> \namespace mom_random !! -!! Provides MOM6 wrappers to the FMS implementation of the Mersenne twister. +!! Provides MOM6 implementation of the Mersenne Twistor, copied from the FMS implementation +!! which was originally written by Robert Pincus (Robert.Pincus@colorado.edu). +!! We once used the FMS implementation directly but since random numers do not need to be +!! infrastructure specific, and because MOM6 should be infrastructure agnostic, we have copied +!! the parts of MT that we used here. !! !! Example usage: !! \code From ca25594d33431778ba37878387d9903e73e1bf65 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 26 Jan 2021 18:59:01 -0500 Subject: [PATCH 172/212] Removed unused module use statements for I/O Removed module use statements for unused subroutines from MOM_io of for the entire netcdf module. All answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 2 +- config_src/solo_driver/user_surface_forcing.F90 | 1 - src/core/MOM_open_boundary.F90 | 5 ++--- src/framework/MOM_diag_remap.F90 | 2 -- src/initialization/MOM_coord_initialization.F90 | 2 -- src/initialization/MOM_fixed_initialization.F90 | 3 --- 6 files changed, 3 insertions(+), 12 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index edb06dc9ba..f635e886a5 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -35,7 +35,7 @@ module ocean_model_mod use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number, stdout +use MOM_io, only : write_version_number, stdout 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 diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index d8f008e9ef..940bcd04b4 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -11,7 +11,6 @@ module user_surface_forcing use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9672356bf6..0cb81e9978 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,13 +9,12 @@ 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 : To_All, SCALAR_PAIR, CGRID_NE, CORNER +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 use MOM_grid, only : ocean_grid_type, hor_index_type use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_io, only : EAST_FACE, NORTH_FACE -use MOM_io, only : slasher, read_data, field_size, SINGLE_FILE +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 use MOM_restart, only : query_initialized, MOM_restart_CS diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 462ba7bf5e..4bea1fc5ae 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -64,8 +64,6 @@ module MOM_diag_remap use MOM_diag_manager, only : 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_io, only : slasher, mom_read_data -use MOM_io, only : file_exists, field_size use MOM_string_functions, only : lowercase, extractWord use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 23d279b65a..454060414b 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -17,8 +17,6 @@ module MOM_coord_initialization use user_initialization, only : user_set_coord use BFB_initialization, only : BFB_set_coord -use netcdf - implicit none ; private public MOM_initialize_coord diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index b075da4141..069d576b2c 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -17,7 +17,6 @@ module MOM_fixed_initialization use MOM_open_boundary, only : open_boundary_config, open_boundary_query use MOM_open_boundary, only : open_boundary_impose_normal_slope use MOM_open_boundary, only : open_boundary_impose_land_mask -! use MOM_shared_initialization, only : MOM_shared_init_init use MOM_shared_initialization, only : MOM_initialize_rotation, MOM_calculate_grad_Coriolis use MOM_shared_initialization, only : initialize_topography_from_file, apply_topography_edits_from_file use MOM_shared_initialization, only : initialize_topography_named, limit_topography, diagnoseMaximumDepth @@ -42,8 +41,6 @@ module MOM_fixed_initialization use Phillips_initialization, only : Phillips_initialize_topography use dense_water_initialization, only : dense_water_initialize_topography -use netcdf - implicit none ; private public MOM_initialize_fixed, MOM_initialize_rotation, MOM_initialize_topography From 9d9a74d10512c4051e4bd6716cd351a1a1e8dabb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 26 Jan 2021 19:04:33 -0500 Subject: [PATCH 173/212] +Document all MOM_io interfaces Added explicit interfaces to field_size, check_nml_error, open_namelist_file, write_version_number and get_filename_appendix to MOM_io.F90. Added explicit interfaces to write_metadata, get_file_times, get_axis_data and get_file_times as well as the newly named routines check_namelist_error, check_namelist_error, write_version, get_field_size to MOM_io_infra.F90. MOM_read_data was expanded to work with regions of 2D fields. MOM_grid_initialize and MOM_restart were altered to use the new interfaces, and support for non-domain-decomposed 2-d, 3-d and 4-d arrays was dropped from the MOM_restart module. All answers are bitwise identical, but there are some expanded capabilities. --- src/framework/MOM_io.F90 | 73 ++++++- src/framework/MOM_io_infra.F90 | 212 ++++++++++++++++++--- src/framework/MOM_restart.F90 | 27 ++- src/initialization/MOM_grid_initialize.F90 | 6 +- 4 files changed, 269 insertions(+), 49 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 9c0cb3a228..a251c52281 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -7,16 +7,17 @@ module MOM_io use MOM_domains, only : MOM_domain_type, domain1D, get_domain_components use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_ensemble_manager, only : get_ensemble_id use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io_infra, only : MOM_read_data, read_data, MOM_read_vector, read_field_chksum +use MOM_io_infra, only : MOM_read_data, read_data=>MOM_read_data, MOM_read_vector, read_field_chksum use MOM_io_infra, only : file_exists, get_file_info, get_file_fields, get_field_atts -use MOM_io_infra, only : open_file, close_file, field_size, fieldtype, field_exists -use MOM_io_infra, only : flush_file, get_filename_appendix, get_ensemble_id +use MOM_io_infra, only : open_file, close_file, get_field_size, fieldtype, field_exists +use MOM_io_infra, only : flush_file, get_filename_suffix use MOM_io_infra, only : get_file_times, axistype, get_axis_data -use MOM_io_infra, only : write_field, write_metadata, write_version_number -use MOM_io_infra, only : open_namelist_file, check_nml_error, io_infra_init, io_infra_end +use MOM_io_infra, only : write_field, write_metadata, 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 @@ -33,13 +34,16 @@ module MOM_io ! These interfaces are actually implemented in this file. public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc +public :: open_namelist_file, check_namelist_error, check_nml_error ! The following are simple pass throughs of routines from MOM_io_infra or other modules public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_fields, get_field_atts public :: get_file_times, open_file, get_axis_data -public :: MOM_read_data, MOM_read_vector, read_data, read_field_chksum +public :: MOM_read_data, MOM_read_vector, read_field_chksum public :: slasher, write_field, write_version_number -public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end +public :: io_infra_init, io_infra_end +! This API is here just to support non-FMS couplers, and should not persist. +public :: read_data ! These are encoding constants. public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE @@ -440,6 +444,12 @@ function num_timelevels(filename, varname, min_dims) result(n_time) n_time = -1 found = .false. + ! To do the same via MOM_io_infra calls, do the following: + ! found = field_exists(filename, varname) + ! call open_file(ncid, filename, action=READONLY_FILE, form=NETCDF_FILE, threading=MULTIPLE) + ! call get_file_info(ncid, ntime=n_time) + ! However, this does not handle the case where the time axis for the variable is not the record axis. + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,"num_timelevels: "//& @@ -788,6 +798,21 @@ subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) call write_field(io_unit, field_md, field, tstamp=tstamp) end subroutine MOM_write_field_0d +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + + call get_field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + +end subroutine field_size + !> Copies a string subroutine safe_string_copy(str1, str2, fieldnm, caller) @@ -865,6 +890,40 @@ function ensembler(name, ens_no_in) result(en_nm) end function ensembler +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_appendix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_suffix(suffix) +end subroutine get_filename_appendix + +!> Write a file version number to the log file or other output file +subroutine write_version_number(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version(version, tag, unit) +end subroutine write_version_number + + +!> Open a single namelist file that is potentially readable by all PEs. +function open_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml" + integer :: unit !< The opened unit number of the namelist file + unit = MOM_namelist_file(file) +end function open_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +function check_nml_error(IOstat, nml_name) result(ierr) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr !< A copy of IOstat that is returned to preserve legacy function behavior + call check_namelist_error(IOstat, nml_name) + ierr = IOstat +end function check_nml_error + !> Initialize the MOM_io module subroutine MOM_io_init(param_file) type(param_file_type), intent(in) :: param_file !< structure indicating the open file to diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index 1a075b63ef..d7d744e740 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -5,20 +5,18 @@ module MOM_io_infra use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind -use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING -use ensemble_manager_mod, only : get_ensemble_id use fms_mod, only : write_version_number, open_namelist_file, 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_io_mod, only : mpp_open, mpp_close, mpp_flush -use mpp_io_mod, only : write_metadata=>mpp_write_meta, mpp_write +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, axistype, get_axis_data=>mpp_get_axis_data +use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data use mpp_io_mod, only : mpp_get_fields, fieldtype -use mpp_io_mod, only : mpp_get_info -use mpp_io_mod, only : get_file_times=>mpp_get_times +use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init ! These are encoding constants. use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII @@ -29,16 +27,15 @@ module MOM_io_infra implicit none ; private ! These interfaces are actually implemented or have explicit interfaces in this file. -public :: MOM_read_data, MOM_read_vector, write_field, open_file, close_file, flush_file -public :: file_exists, field_exists, read_field_chksum -public :: get_file_info, get_file_fields, get_field_atts, io_infra_init, io_infra_end -! The following are simple pass throughs of routines from other modules. They need -! to have explicit interfaces added to this file. -public :: fieldtype, axistype, field_size, get_filename_appendix -public :: get_file_times, read_data, get_axis_data -public :: write_metadata, write_version_number, get_ensemble_id -public :: open_namelist_file, check_nml_error -! These are encoding constants. +public :: open_file, close_file, flush_file, file_exists, get_filename_suffix +public :: get_file_info, get_file_fields, get_file_times +public :: MOM_read_data, MOM_read_vector, write_metadata, write_field +public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version +! These types are inherited from underlying infrastructure code, to act as containers for +! information about fields and axes, respectively, and are opaque to this module. +public :: fieldtype, axistype +! These are encoding constant parmeters. public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE public :: CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -53,7 +50,7 @@ module MOM_io_infra interface MOM_read_data module procedure MOM_read_data_4d module procedure MOM_read_data_3d - module procedure MOM_read_data_2d + module procedure MOM_read_data_2d, MOM_read_data_2d_region module procedure MOM_read_data_1d module procedure MOM_read_data_0d end interface @@ -72,7 +69,12 @@ module MOM_io_infra interface MOM_read_vector module procedure MOM_read_vector_3d module procedure MOM_read_vector_2d -end interface +end interface MOM_read_vector + +!> Write metadata about a variable or axis to a file and store it for later reuse +interface write_metadata + module procedure write_metadata_axis, write_metadata_field +end interface write_metadata contains @@ -150,6 +152,30 @@ subroutine io_infra_end() call fms_io_exit() end subroutine io_infra_end +!> Open a single namelist file that is potentially readable by all PEs. +function MOM_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml". + integer :: unit !< The opened unit number of the namelist file + unit = open_namelist_file(file) +end function MOM_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +subroutine check_namelist_error(IOstat, nml_name) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr + ierr = check_nml_error(IOstat, nml_name) +end subroutine check_namelist_error + +!> Write a file version number to the log file or other output file +subroutine write_version(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version_number(version, tag, unit) +end subroutine write_version !> open_file opens a file for parallel or single-file I/O. subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domain, MOM_domain) @@ -179,6 +205,14 @@ subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domai endif end subroutine open_file +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_suffix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_appendix(suffix) +end subroutine get_filename_suffix + + !> Get information about the number of dimensions, variables, global attributes and time levels !! in the file associated with an open file unit subroutine get_file_info(unit, ndim, nvar, natt, ntime) @@ -200,6 +234,25 @@ subroutine get_file_info(unit, ndim, nvar, natt, ntime) end subroutine get_file_info + +!> Get the times of records from a file + !### Modify this to also convert to time_type, using information about the dimensions? +subroutine get_file_times(unit, time_values, ntime) + integer, intent(in) :: unit !< The I/O unit for the open file + 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 + + integer :: ntimes + + if (allocated(time_values)) deallocate(time_values) + call get_file_info(unit, ntime=ntimes) + if (present(ntime)) ntime = ntimes + if (ntimes > 0) then + allocate(time_values(ntimes)) + call mpp_get_times(unit, time_values) + endif +end subroutine get_file_times + !> Set up the field information (e.g., names and metadata) for all of the variables in a file. The !! argument fields must be allocated with a size that matches the number of variables in a file. subroutine get_file_fields(unit, fields) @@ -238,7 +291,30 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) end function field_exists -!> This function uses the fms_io function read_data to read a scalar +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + + call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + +end subroutine get_field_size + +!> 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 + +!> This routine uses the fms_io subroutine read_data to read a scalar !! data field named "fieldname" from file "filename". subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale) character(len=*), intent(in) :: filename !< The name of the file to read @@ -256,7 +332,7 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale) end subroutine MOM_read_data_0d -!> This function uses the fms_io function read_data to read a 1-D +!> This routine uses the fms_io subroutine read_data to read a 1-D !! data field named "fieldname" from file "filename". subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) character(len=*), intent(in) :: filename !< The name of the file to read @@ -274,7 +350,7 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) end subroutine MOM_read_data_1d -!> This function uses the fms_io function read_data to read a distributed +!> This routine uses the fms_io subroutine read_data to read a distributed !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & @@ -302,7 +378,42 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_2d -!> This function uses the fms_io function read_data to read a distributed +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 2-D data field named "fieldname" from file "filename". +subroutine MOM_read_data_2d_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 2-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 2-d read, the 3rd + !! and 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 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 + ! Dangerously rescale the whole array + data(:,:) = scale*data(:,:) + endif ; endif + +end subroutine MOM_read_data_2d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & @@ -330,7 +441,7 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_3d -!> This function uses the fms_io function read_data to read a distributed +!> 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. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & @@ -359,7 +470,7 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_4d -!> This function uses the fms_io function read_data to read a pair of distributed +!> This routine uses the fms_io subroutine read_data to read a pair of distributed !! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & @@ -403,7 +514,7 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data end subroutine MOM_read_vector_2d -!> This function uses the fms_io function read_data to read a pair of distributed +!> This routine uses the fms_io subroutine read_data to read a pair of distributed !! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & @@ -511,6 +622,7 @@ subroutine write_field_0d(io_unit, field_md, field, tstamp) call mpp_write(io_unit, field_md, field, tstamp=tstamp) end subroutine write_field_0d +!> Write the data for an axis subroutine MOM_write_axis(io_unit, axis) integer, intent(in) :: io_unit !< File I/O unit handle type(axistype), intent(in) :: axis !< An axis type variable with information to write @@ -519,4 +631,54 @@ subroutine MOM_write_axis(io_unit, axis) end subroutine MOM_write_axis +!> Store information about an axis in a previously defined axistype and write this +!! information to the file indicated by unit. +subroutine write_metadata_axis( unit, axis, name, units, longname, cartesian, sense, domain, data, calendar) + integer, intent(in) :: unit !< The I/O unit for the file to write to + type(axistype), intent(inout) :: axis !< The axistype where this information is stored. + character(len=*), intent(in) :: name !< 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 + character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis + + call mpp_write_meta(unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & + domain=domain, data=data, calendar=calendar) +end subroutine write_metadata_axis + +!> Store information about an output variable in a previously defined fieldtype and write this +!! information to the file indicated by unit. +subroutine write_metadata_field(unit, field, axes, name, units, longname, & + min, max, fill, scale, add, pack, standard_name, checksum) + integer, intent(in) :: unit !< The I/O unit for the file to write to + type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored + type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable + character(len=*), intent(in) :: name !< 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 + real, optional, intent(in) :: min !< The minimum valid value for this variable + real, optional, intent(in) :: max !< The maximum valid value for this variable + real, optional, intent(in) :: fill !< Missing data fill value + real, optional, intent(in) :: scale !< An multiplicative factor by which to scale + !! the variable before output + real, optional, intent(in) :: add !< An offset to add to the variable before output + 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=8), dimension(:), & + optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + + + call mpp_write_meta( unit, field, axes, name, units, longname, & + min=min, max=max, fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + +end subroutine write_metadata_field + end module MOM_io_infra diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 6780eff644..d0b3b24aef 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1084,7 +1084,7 @@ subroutine restore_state(filename, directory, day, G, CS) integer :: i, n, m, missing_fields integer :: isL, ieL, jsL, jeL, is0, js0 integer :: sizes(7) - integer :: ndim, nvar, natt, ntime, pos + integer :: nvar, ntime, pos integer :: unit(CS%max_fields) ! The I/O units of all open files. character(len=200) :: unit_path(CS%max_fields) ! The file names. @@ -1119,11 +1119,9 @@ 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_info(unit(n), ndim, nvar, natt, ntime) + call get_file_times(unit(n), time_vals, ntime) if (ntime < 1) cycle - allocate(time_vals(ntime)) - call get_file_times(unit(n), time_vals) t1 = time_vals(1) deallocate(time_vals) @@ -1138,11 +1136,9 @@ subroutine restore_state(filename, directory, day, G, CS) ! if they differ from the first time. if (is_root_pe()) then do m = n+1,num_file - call get_file_info(unit(n), ndim, nvar, natt, ntime) + call get_file_times(unit(n), time_vals, ntime) if (ntime < 1) cycle - allocate(time_vals(ntime)) - call get_file_times(unit(n), time_vals) t2 = time_vals(1) deallocate(time_vals) @@ -1157,7 +1153,7 @@ 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(unit(n), ndim, nvar, natt, ntime) + call get_file_info(unit(n), nvar=nvar) allocate(fields(nvar)) call get_file_fields(unit(n), fields(1:nvar)) @@ -1216,8 +1212,9 @@ subroutine restore_state(filename, directory, day, G, CS) call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & G%Domain, timelevel=1, position=pos) else ! This array is not domain-decomposed. This variant may be under-tested. - call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & - no_domain=.true., timelevel=1) + call MOM_error(FATAL, & + "MOM_restart does not support 2-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p,no_domain=.true., timelevel=1) endif if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. @@ -1225,8 +1222,9 @@ subroutine restore_state(filename, directory, day, G, CS) call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & G%Domain, timelevel=1, position=pos) else ! This array is not domain-decomposed. This variant may be under-tested. - call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & - no_domain=.true., timelevel=1) + call MOM_error(FATAL, & + "MOM_restart does not support 3-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, no_domain=.true., timelevel=1) endif if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. @@ -1234,8 +1232,9 @@ subroutine restore_state(filename, directory, day, G, CS) call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & G%Domain, timelevel=1, position=pos) else ! This array is not domain-decomposed. This variant may be under-tested. - call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - no_domain=.true., timelevel=1) + call MOM_error(FATAL, & + "MOM_restart does not support 4-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, no_domain=.true., timelevel=1) endif if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) else diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index b5685745ac..0fac3e15b4 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -12,7 +12,7 @@ module MOM_grid_initialize use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io, only : MOM_read_data, read_data, slasher, file_exists, stdout +use MOM_io, only : MOM_read_data, slasher, file_exists, stdout use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE use MOM_unit_scaling, only : unit_scale_type @@ -333,7 +333,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) start(2) = 2 ; nread(1) = ni+1 ; nread(2) = 2 allocate( tmpGlbl(ni+1,2) ) if (is_root_PE()) & - call read_data(filename, "x", tmpGlbl, start, nread, no_domain=.TRUE.) + call MOM_read_data(filename, "x", tmpGlbl, start, nread, no_domain=.TRUE.) call broadcast(tmpGlbl, 2*(ni+1), root_PE()) ! I don't know why the second axis is 1 or 2 here. -RWH @@ -351,7 +351,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) start(:) = 1 ; nread(:) = 1 start(1) = int(ni/4)+1 ; nread(2) = nj+1 if (is_root_PE()) & - call read_data(filename, "y", tmpGlbl, start, nread, no_domain=.TRUE.) + call MOM_read_data(filename, "y", tmpGlbl, start, nread, no_domain=.TRUE.) call broadcast(tmpGlbl, nj+1, root_PE()) do j=G%jsg,G%jeg From 291505cd17f6313d0911c99e1da9d1bcae82ae52 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 27 Jan 2021 08:58:01 -0500 Subject: [PATCH 174/212] Change netcdf use statements to use, only Modified the module use statements for netcdf to explicitly list the routines and constants that are used. Also added comments documenting the purpose of the encoding constants that MOM_io makes available. Also added a missing NF90_close call to Surface_Bands_by_data_override. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 3 +- src/diagnostics/MOM_sum_output.F90 | 7 ++- src/framework/MOM_io.F90 | 53 ++++++++++--------- .../MOM_shared_initialization.F90 | 5 +- src/tracer/MOM_tracer_Z_init.F90 | 6 ++- src/user/MOM_wave_interface.F90 | 9 +++- 6 files changed, 50 insertions(+), 33 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e827b3ff3a..dc85fab7d3 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -30,7 +30,8 @@ module MOM_regridding 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 netcdf ! Used by check_grid_def() +! Direct netcdf calls are used by check_grid_def() +use netcdf, only : NF90_open, NF90_inq_varid, NF90_get_att, NF90_NOERR, NF90_NOWRITE implicit none ; private diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 0746a120f2..ca57926ab1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -26,7 +26,10 @@ module MOM_sum_output use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use netcdf +use netcdf, only : NF90_create, NF90_def_dim, NF90_def_var, NF90_put_att, NF90_enddef +use netcdf, only : NF90_put_var, NF90_open, NF90_close, NF90_inquire_variable, NF90_strerror +use netcdf, only : NF90_inq_varid, NF90_inquire_dimension, NF90_get_var, NF90_get_att +use netcdf, only : NF90_DOUBLE, NF90_NOERR, NF90_NOWRITE, NF90_GLOBAL, NF90_ENOTATT implicit none ; private @@ -1351,7 +1354,7 @@ subroutine read_depth_list(G, US, CS, filename) character(len=240) :: var_name, var_msg real, allocatable :: tmp(:) integer :: ncid, status, varid, list_size, k - integer :: ndim, len, var_dim_ids(NF90_MAX_VAR_DIMS) + integer :: ndim, len, var_dim_ids(8) character(len=16) :: depth_file_chksum, depth_grid_chksum character(len=16) :: area_file_chksum, area_grid_chksum integer :: depth_attr_status, area_attr_status diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index a251c52281..d990f2eea6 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -11,7 +11,8 @@ module MOM_io use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io_infra, only : MOM_read_data, read_data=>MOM_read_data, MOM_read_vector, read_field_chksum +use MOM_io_infra, only : MOM_read_data, MOM_read_vector, read_field_chksum +use MOM_io_infra, only : read_data=>MOM_read_data ! read_data will be removed soon. use MOM_io_infra, only : file_exists, get_file_info, get_file_fields, get_field_atts use MOM_io_infra, only : open_file, close_file, get_field_size, fieldtype, field_exists use MOM_io_infra, only : flush_file, get_filename_suffix @@ -26,8 +27,7 @@ module MOM_io use iso_fortran_env, only : stdout_iso=>output_unit, stderr_iso=>error_unit use netcdf, only : NF90_open, NF90_inquire, NF90_inq_varids, NF90_inquire_variable -use netcdf, only : NF90_Inquire_Dimension, NF90_max_name, NF90_max_var_dims -use netcdf, only : NF90_STRERROR, NF90_NOWRITE, NF90_NOERR +use netcdf, only : NF90_Inquire_Dimension, NF90_STRERROR, NF90_NOWRITE, NF90_NOERR implicit none ; private @@ -35,18 +35,23 @@ module MOM_io public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc public :: open_namelist_file, check_namelist_error, check_nml_error -! The following are simple pass throughs of routines from MOM_io_infra or other modules -public :: close_file, field_exists, field_size, fieldtype, get_filename_appendix -public :: file_exists, flush_file, get_file_info, get_file_fields, get_field_atts -public :: get_file_times, open_file, get_axis_data +! The following are simple pass throughs of routines from MOM_io_infra or other modules. +public :: file_exists, open_file, close_file, flush_file, get_filename_appendix +public :: get_file_info, field_exists, get_file_fields, get_file_times +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 :: io_infra_init, io_infra_end -! This API is here just to support non-FMS couplers, and should not persist. +! This API is here just to support potential use by non-FMS drivers, and should not persist. public :: read_data -! These are encoding constants. -public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE -public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE +!> These encoding constants are used to indicate the file format +public :: ASCII_FILE, NETCDF_FILE +!> These encoding constants are used to indicate whether the file is domain decomposed +public :: MULTIPLE, SINGLE_FILE +!> These encoding constants are used to indicate the access mode for a file +public :: APPEND_FILE, OVERWRITE_FILE, READONLY_FILE, WRITEONLY_FILE +!> These encoding constants are used to indicate the discretization position of a variable public :: CENTER, CORNER, NORTH_FACE, EAST_FACE !> Write a registered field to an output file, potentially with rotation @@ -435,16 +440,14 @@ function num_timelevels(filename, varname, min_dims) result(n_time) integer :: n_time !< number of time levels varname has in filename logical :: found - character(len=200) :: msg - character(len=nf90_max_name) :: name + character(len=256) :: msg, name integer :: ncid, nvars, status, varid, ndims, n - integer, allocatable :: varids(:) - integer, dimension(nf90_max_var_dims) :: dimids + integer, allocatable :: varids(:), dimids(:) n_time = -1 found = .false. - ! To do the same via MOM_io_infra calls, do the following: + ! To do almost the same via MOM_io_infra calls, do the following: ! found = field_exists(filename, varname) ! call open_file(ncid, filename, action=READONLY_FILE, form=NETCDF_FILE, threading=MULTIPLE) ! call get_file_info(ncid, ntime=n_time) @@ -491,9 +494,8 @@ function num_timelevels(filename, varname, min_dims) result(n_time) if (trim(lowercase(name)) == trim(lowercase(varname))) then if (found) then - call MOM_error(WARNING,"num_timelevels: "//& - " Two variables match the case-insensitive name "//trim(varname)//& - " in file "//trim(filename)//" - "//trim(NF90_STRERROR(status))) + call MOM_error(WARNING, "num_timelevels: Two variables match the case-insensitive name "//& + trim(varname)//" in file "//trim(filename)) else varid = varids(n) ; found = .true. endif @@ -518,19 +520,19 @@ function num_timelevels(filename, varname, min_dims) result(n_time) 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.") + call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//& + trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") elseif (ndims == min_dims - 1) then n_time = 0 ; return endif endif - status = nf90_inquire_variable(ncid, varid, dimids = dimids(1:ndims)) + allocate(dimids(ndims)) + status = nf90_inquire_variable(ncid, varid, dimids=dimids(1:ndims)) if (status /= NF90_NOERR) then call MOM_error(WARNING,"num_timelevels: "//trim(NF90_STRERROR(status))//& " Getting last dimension ID for "//trim(varname)//" in "//trim(filename)) - return + deallocate(dimids) ; return endif status = nf90_Inquire_Dimension(ncid, dimids(ndims), len=n_time) @@ -538,8 +540,9 @@ function num_timelevels(filename, varname, min_dims) result(n_time) trim(NF90_STRERROR(status))//" Getting number of time levels of "//& trim(varname)//" in "//trim(filename)) -end function num_timelevels + deallocate(dimids) +end function num_timelevels !> Returns a vardesc type whose elements have been filled with the provided !! fields. The argument name is required, while the others are optional and diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 24318954a1..22e8227637 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -17,7 +17,8 @@ module MOM_shared_initialization use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use netcdf +use netcdf, only : NF90_open, NF90_inq_varid, NF90_get_var, NF90_close +use netcdf, only : NF90_inq_dimid, NF90_inquire_dimension, NF90_NOWRITE, NF90_NOERR implicit none ; private @@ -189,7 +190,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - ! Local variables + ! Local variablesNF real :: m_to_Z ! A dimensional rescaling factor. character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 1e79061dcd..8381c85538 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -11,7 +11,9 @@ module MOM_tracer_Z_init use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use netcdf +use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var +use netcdf, only : NF90_get_att, NF90_inquire_dimension, NF90_close, NF90_strerror +use netcdf, only : NF90_NOWRITE, NF90_NOERR implicit none ; private @@ -402,7 +404,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & character(len=120) :: dim_name, edge_name, tr_msg, dim_msg logical :: monotonic integer :: ncid, status, intid, tr_id, layid, k - integer :: nz_edge, ndim, tr_dim_ids(NF90_MAX_VAR_DIMS) + integer :: nz_edge, ndim, tr_dim_ids(8) mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index df4b2a30fd..4531c63b99 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -18,6 +18,9 @@ module MOM_wave_interface use MOM_verticalgrid, only : verticalGrid_type use data_override_mod, only : data_override_init, data_override +use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var +use netcdf, only : NF90_inquire_dimension, NF90_close, NF90_NOWRITE, NF90_NOERR + implicit none ; private #include @@ -773,12 +776,12 @@ end subroutine Update_Stokes_Drift !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) - use NETCDF type(time_type), intent(in) :: day_center !< Center of timestep type(wave_parameters_CS), pointer :: CS !< Wave 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 + ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [m s-1] real :: temp_y(SZI_(G),SZJ_(G)) ! Psuedo-meridional Stokes drift of band at h-points [m s-1] @@ -895,6 +898,10 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) enddo endif + rcode_wn = NF90_close(ncid) + if (rcode_wn /= 0) call MOM_error(WARNING, & + "Error closing file "//trim(SurfBandFileName)//" in MOM_wave_interface.") + endif do b = 1,CS%NumBands From 0977e13ab5b8063105ef6566c95bdf70fe414b16 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 27 Jan 2021 09:47:25 -0500 Subject: [PATCH 175/212] Undid typo --- src/initialization/MOM_shared_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 22e8227637..d32f972258 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -190,7 +190,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - ! Local variablesNF + ! Local variables real :: m_to_Z ! A dimensional rescaling factor. character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. From 4744e666807d95523aacb25d75d4cf106a66f58c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 27 Jan 2021 10:40:27 -0500 Subject: [PATCH 176/212] Add sphinx bibtex extension configuration parameter --- docs/conf.py | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/conf.py b/docs/conf.py index 43f09417fd..d705e19878 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -140,6 +140,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): 'sphinxcontrib.autodoc_doxygen', 'sphinxfortran.fortran_domain', ] +bibtex_bibfiles = ['ocean.bib', 'references.bib', 'zotero.bib'] autosummary_generate = ['api/modules.rst', 'api/pages.rst'] doxygen_xml = 'xml' From 932c29d69fb5ff01f80298676162369e64000512 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 27 Jan 2021 10:47:04 -0500 Subject: [PATCH 177/212] Rename MOM_ensemble_manager to MOM_ensemble_manager_infra - Pass throught interfaces to FMS with documentation. --- src/framework/MOM_ensemble_manager.F90 | 18 ---- src/framework/MOM_ensemble_manager_infra.F90 | 96 ++++++++++++++++++++ 2 files changed, 96 insertions(+), 18 deletions(-) delete mode 100644 src/framework/MOM_ensemble_manager.F90 create mode 100644 src/framework/MOM_ensemble_manager_infra.F90 diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90 deleted file mode 100644 index df1c30fc74..0000000000 --- a/src/framework/MOM_ensemble_manager.F90 +++ /dev/null @@ -1,18 +0,0 @@ -!> A simple (very thin) wrapper for managing ensemble member layout information -module MOM_ensemble_manager - -! This file is part of MOM6. See LICENSE.md for the license. - -use ensemble_manager_mod, only : ensemble_manager_init, ensemble_pelist_setup -use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size -use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist - -implicit none ; private - -public :: ensemble_manager_init, ensemble_pelist_setup -public :: get_ensemble_id, get_ensemble_size -public :: get_ensemble_pelist, get_ensemble_filter_pelist - -! There need to be documented APIs in this module. - -end module MOM_ensemble_manager diff --git a/src/framework/MOM_ensemble_manager_infra.F90 b/src/framework/MOM_ensemble_manager_infra.F90 new file mode 100644 index 0000000000..8c8c34bed9 --- /dev/null +++ b/src/framework/MOM_ensemble_manager_infra.F90 @@ -0,0 +1,96 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init +use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup +use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id +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 + +implicit none ; private + +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist + +contains + +!> 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() + +end subroutine ensemble_manager_init + +!> Create a list of processing elements (PEs) across components +!! associated with the current ensemble member. +subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + logical, intent(in) :: concurrent !< A logical flag, if True, then + !! ocean fast PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs + integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs + integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs + integer, dimension(:), intent(inout) :: Ice_pelist !< A list of Ice PEs + + + call FMS_ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + +end subroutine ensemble_pelist_setup + +!> Returns the numeric id for the current ensemble member +function get_ensemble_id() + integer :: get_ensemble_id + + get_ensemble_id = FMS_get_ensemble_id() + +end function get_ensemble_id + +!> Returns ensemble information as follows, +!! index (1) :: ensemble size +!! index (2) :: Number of PEs per ensemble member +!! index (3) :: Number of ocean PEs per ensemble member +!! index (4) :: Number of atmos PEs per ensemble member +!! index (5) :: Number of land PEs per ensemble member +!! index (6) :: Number of ice PEs per ensemble member +function get_ensemble_size() + integer, dimension(6) :: get_ensemble_size + + get_ensemble_size = FMS_get_ensemble_size() + +end function get_ensemble_size + +!> Returns the list of PEs associated with all ensemble members +!! Results are stored in the argument array which ust be large +!! enough to contain the list. If the optional name argument is present, +!! the returned processor list are for a particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_pelist(pelist, name) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), intent(in), optional :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_ensemble_pelist(pelist,name) + +end subroutine get_ensemble_pelist + +!> Returns the list of PEs associated with an ensemble filter application. +!! If the optional name argument is present, the returned list is for a +!! particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_filter_pelist(pelist, name) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_Ensemble_filter_pelist(pelist,name) + +end subroutine get_ensemble_filter_pelist + +end module MOM_ensemble_manager From 82a4f7089da3cfd07ea9e1c018c5adb24455aa22 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 27 Jan 2021 14:55:43 -0500 Subject: [PATCH 178/212] +Add explicit interfaces for MOM_domain_infra Added explicit interfaces for the remaining routines in MOM_domain_infra, including global_field, broadcast_domain, and compute_block_extent, and created a new stand-alone routine MOM_define_layout inside of MOM_domains.F90 to replace the mpp routine that it had previously wrapped. Also added comments explicitly documenting some of the integer parameters that are used to signal staggering or communication patterns. All answers are bitwise identical, but some routines have been recreated within the MOM6 code, in the localized case of MOM_define_layout with a slightly different interface. --- src/framework/MOM_domain_infra.F90 | 87 +++++++++++++++++++----------- src/framework/MOM_domains.F90 | 46 +++++++++++++--- 2 files changed, 93 insertions(+), 40 deletions(-) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 1f0594ef0d..d980c48317 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -7,22 +7,17 @@ module MOM_domain_infra use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL -use mpp_domains_mod, only : MOM_define_layout => mpp_define_layout, mpp_get_boundary -use mpp_domains_mod, only : MOM_define_io_domain => mpp_define_io_domain -use mpp_domains_mod, only : MOM_define_domain => mpp_define_domains -use mpp_domains_mod, only : domain2D, domain1D, mpp_get_data_domain, mpp_get_domain_components -use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain -use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain -use mpp_domains_mod, only : mpp_update_domains, global_field_sum => mpp_global_sum +use mpp_domains_mod, only : domain2D, domain1D, group_pass_type => mpp_group_update_type +use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains, global_field_sum => mpp_global_sum use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update -use mpp_domains_mod, only : group_pass_type => mpp_group_update_type 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 : compute_block_extent => mpp_compute_block_extent -use mpp_domains_mod, only : mpp_redistribute -use mpp_domains_mod, only : global_field => mpp_global_field -use mpp_domains_mod, only : broadcast_domain => mpp_broadcast_domain +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 : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE @@ -33,23 +28,24 @@ module MOM_domain_infra implicit none ; private -public :: MOM_define_domain, MOM_define_layout -public :: create_MOM_domain, clone_MOM_domain, get_domain_components -public :: deallocate_MOM_domain -public :: get_domain_extent -public :: pass_var, pass_vector, fill_symmetric_edges, global_field_sum -public :: pass_var_start, pass_var_complete -public :: pass_vector_start, pass_vector_complete -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -public :: CORNER, CENTER, NORTH_FACE, EAST_FACE -public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners -public :: create_group_pass, do_group_pass, group_pass_type -public :: start_group_pass, complete_group_pass -public :: compute_block_extent, get_global_shape -public :: global_field, redistribute_array, broadcast_domain -public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These types are inherited from mpp, but are treated as opaque here. +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 :: pass_var, pass_vector, fill_symmetric_edges +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 +public :: redistribute_array, broadcast_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind -public :: domain2D, domain1D +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These are encoding constant parmeters. +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 +! 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 !> Do a halo update on an array interface pass_var @@ -1133,7 +1129,7 @@ subroutine do_group_pass(group, MOM_dom, clock) type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain !! needed to determine where data should be !! sent. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. real :: d_type @@ -1618,19 +1614,19 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & endif if (associated(MD_in%maskmap)) then - call MOM_define_domain( global_indices, MD_in%layout, mpp_domain, & + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & maskmap=MD_in%maskmap ) else - call MOM_define_domain( global_indices, MD_in%layout, mpp_domain, & + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) endif if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & (MD_in%layout(1)*MD_in%layout(2) > 1)) then - call MOM_define_io_domain(mpp_domain, MD_in%io_layout) + call mpp_define_io_domain(mpp_domain, MD_in%io_layout) endif end subroutine clone_MD_to_d2D @@ -1837,6 +1833,33 @@ 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 +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 + 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_block_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_block_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. + + call mpp_broadcast_domain(domain) +end subroutine broadcast_domain + +!> Broadcast an entire 2-d array from the root processor to all others. +subroutine global_field(domain, local, global) + type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition + real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE + real, dimension(:,:), intent(out) :: global !< The whole global array + + call mpp_global_field(domain, local, global) +end subroutine global_field + !> Returns arrays of the i- and j- sizes of the h-point computational domains for each !! element of the grid layout. Any input values in the extent arrays are discarded, so !! they are effectively intent out despite their declared intent of inout. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index d230ecdf74..b1b3a3c6a8 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -6,21 +6,20 @@ module MOM_domains use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs -use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D +use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, group_pass_type use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain -use MOM_domain_infra, only : MOM_define_domain, MOM_define_layout use MOM_domain_infra, only : get_domain_extent, get_domain_components use MOM_domain_infra, only : compute_block_extent, get_global_shape use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum use MOM_domain_infra, only : pass_var_start, pass_var_complete use MOM_domain_infra, only : pass_vector_start, pass_vector_complete -use MOM_domain_infra, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domain_infra, only : create_group_pass, do_group_pass use MOM_domain_infra, only : start_group_pass, complete_group_pass use MOM_domain_infra, only : global_field, redistribute_array, broadcast_domain +use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM 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_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_io_infra, only : file_exists @@ -43,12 +42,17 @@ module MOM_domains ! Multi-variable group communication routines and type public :: create_group_pass, do_group_pass, group_pass_type, start_group_pass, complete_group_pass ! Global reduction routines -public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs +public :: sum_across_PEs, min_across_PEs, max_across_PEs public :: global_field, redistribute_array, broadcast_domain -! Coded integers for controlling communication or staggering -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +!> These encoding constants are used to indicate the staggering of scalars and vectors +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +!> These encoding constants are used to indicate the discretization position of a variable public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +!> These encoding constants indicate communication patterns. In practice they can be added. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +! 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 contains @@ -316,7 +320,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif if ( (layout(1) == 0) .and. (layout(2) == 0) ) & - call MOM_define_layout( (/ 1, n_global(1), 1, n_global(2) /), PEs_used, layout) + call MOM_define_layout(n_global, PEs_used, layout) if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) if ( (layout(1) == 0) .and. (layout(2) /= 0) ) layout(1) = PEs_used / layout(2) @@ -359,4 +363,30 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & end subroutine MOM_domains_init +!> Given a global array size and a number of (logical) processors, provide a layout of the +!! processors in the two directions where the total number of processors is the product of +!! the two layouts and number of points in the partitioned arrays are as close as possible +!! to an aspect ratio of 1. +subroutine MOM_define_layout(n_global, ndivs, layout) + integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions + integer, intent(in) :: ndivs !< The total number of (logical) PEs + integer, dimension(2), intent(out) :: layout !< The generated layout of PEs + + ! Local variables + integer :: isz, jsz, idiv, jdiv + + ! At present, this algorithm is a copy of mpp_define_layout, but it could perhaps be improved? + + isz = n_global(1) ; jsz = n_global(2) + ! First try to divide ndivs to match the domain aspect ratio. If this is not an even + ! divisor of ndivs, reduce idiv until a factor is found. + idiv = max(nint( sqrt(float(ndivs*isz)/jsz) ), 1) + do while( mod(ndivs,idiv) /= 0 ) + idiv = idiv - 1 + enddo ! This will terminate at idiv=1 if not before + jdiv = ndivs / idiv + + layout = (/ idiv, jdiv /) +end subroutine MOM_define_layout + end module MOM_domains From ac98a60eeb6e7634add150cbb4700be37fb785fe Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 27 Jan 2021 16:03:44 -0500 Subject: [PATCH 179/212] finished wrapping FMS ensemble_manager --- src/framework/MOM_ensemble_manager.F90 | 36 ++++++++++++++++++++ src/framework/MOM_ensemble_manager_infra.F90 | 4 +-- 2 files changed, 38 insertions(+), 2 deletions(-) create mode 100644 src/framework/MOM_ensemble_manager.F90 diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90 new file mode 100644 index 0000000000..e431212524 --- /dev/null +++ b/src/framework/MOM_ensemble_manager.F90 @@ -0,0 +1,36 @@ +!> Manages ensemble member layout information +module MOM_ensemble_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ensemble_manager_infra, only : ensemble_manager_init +use MOM_ensemble_manager_infra, only : ensemble_pelist_setup +use MOM_ensemble_manager_infra, only : get_ensemble_id +use MOM_ensemble_manager_infra, only : get_ensemble_size +use MOM_ensemble_manager_infra, only : get_ensemble_pelist +use MOM_ensemble_manager_infra, only : get_ensemble_filter_pelist + +implicit none ; private + +!> Public functions: +!> mom_ensemble_manager_infra:ensemble_manager_init +public :: ensemble_manager_init +!> mom_ensemble_manager_infra:ensemble_pelist_setup +public :: ensemble_pelist_setup +!> mom_ensemble_manager_infra:get_ensemble_id +public :: get_ensemble_id +!> mom_ensemble_manager_infra:get_ensemble_size +public :: get_ensemble_size +!> mom_ensemble_manager_infra:get_ensemble_pelist +public :: get_ensemble_pelist +!> mom_ensemble_manager_infra:get_ensemble_filter_pelist +public :: get_ensemble_filter_pelist + + + + +end module MOM_ensemble_manager + +!> \namespace mom_ensemble_manager +!! +!! APIs are defined and implemented in MOM_ensemble_manager_infra diff --git a/src/framework/MOM_ensemble_manager_infra.F90 b/src/framework/MOM_ensemble_manager_infra.F90 index 8c8c34bed9..314bdc0670 100644 --- a/src/framework/MOM_ensemble_manager_infra.F90 +++ b/src/framework/MOM_ensemble_manager_infra.F90 @@ -1,5 +1,5 @@ !> A simple (very thin) wrapper for managing ensemble member layout information -module MOM_ensemble_manager +module MOM_ensemble_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. @@ -93,4 +93,4 @@ subroutine get_ensemble_filter_pelist(pelist, name) end subroutine get_ensemble_filter_pelist -end module MOM_ensemble_manager +end module MOM_ensemble_manager_infra From d4aadb385b842cb93b0ecc4f1ea5e46c5b179bb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 27 Jan 2021 19:36:57 -0500 Subject: [PATCH 180/212] Added explicit interfaces for MOM_error_infra Added explicit interfaces with documentation for the routines MOM_err, stdout and stdlog in MOM_error_infra.F90. Also clarified some of the comments describing MOM_error.F90. All answers are bitwise identical and no interfaces are changed as seen from outside MOM_error. --- src/framework/MOM_error_handler.F90 | 22 +++++++++++--------- src/framework/MOM_error_infra.F90 | 31 ++++++++++++++++++++++------- 2 files changed, 37 insertions(+), 16 deletions(-) diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 336a4942be..6051fed08b 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -3,15 +3,18 @@ module MOM_error_handler ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_infra, only : MOM_err, NOTE, WARNING, FATAL -use MOM_error_infra, only : is_root_pe, stdlog, stdout +use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL implicit none ; private -public MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe, stdlog, stdout -public MOM_set_verbosity, MOM_get_verbosity, MOM_verbose_enough -public callTree_showQuery, callTree_enter, callTree_leave, callTree_waypoint -public assert +! These routines are found in this module. +public :: MOM_error, MOM_mesg, assert +public :: MOM_set_verbosity, MOM_get_verbosity, MOM_verbose_enough +public :: callTree_showQuery, callTree_enter, callTree_leave, callTree_waypoint +! These routines are simply passed-through from MOM_error_infra +public :: is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL integer :: verbosity = 6 !< Verbosity level: @@ -39,7 +42,8 @@ module MOM_error_handler contains -!> This provides a convenient interface for writing an informative comment. +!> This provides a convenient interface for writing an informative comment, depending +!! on the model's current verbosity setting and the verbosity level for this message. subroutine MOM_mesg(message, verb, all_print) character(len=*), intent(in) :: message !< A message to write out integer, optional, intent(in) :: verb !< A level of verbosity for this message @@ -58,9 +62,9 @@ subroutine MOM_mesg(message, verb, all_print) end subroutine MOM_mesg !> This provides a convenient interface for writing an error message -!! with run-time filter based on a verbosity. +!! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) - integer, intent(in) :: level !< The verbosity level of this message + integer, intent(in) :: level !< The severity level of this message 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. diff --git a/src/framework/MOM_error_infra.F90 b/src/framework/MOM_error_infra.F90 index 21eb14ef3d..e5a8b8dc68 100644 --- a/src/framework/MOM_error_infra.F90 +++ b/src/framework/MOM_error_infra.F90 @@ -3,21 +3,38 @@ module MOM_error_infra ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_mod, only : MOM_err => mpp_error, NOTE, WARNING, FATAL -use mpp_mod, only : mpp_pe, mpp_root_pe, stdlog, stdout +use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout +use mpp_mod, only : NOTE, WARNING, FATAL implicit none ; private -public MOM_err, NOTE, WARNING, FATAL, is_root_pe, stdlog, stdout +public :: MOM_err, is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL contains -! MOM_err writes an error message, and may stop the run depending on the -! severity of the error. +!> MOM_err writes an error message, and may cause the run to stop depending on the +!! severity of the error. +subroutine MOM_err(severity, message) + integer, intent(in) :: severity !< The severity level of this error + character(len=*), intent(in) :: message !< A message to write out + + call mpp_error(severity, message) +end subroutine MOM_err + +!> stdout returns the standard Fortran unit number for output +integer function stdout() + stdout = mpp_stdout() +end function stdout + +!> stdlog returns the standard Fortran unit number to use to log messages +integer function stdlog() + stdlog = mpp_stdlog() +end function stdlog !> is_root_pe returns .true. if the current PE is the root PE. -function is_root_pe() - logical :: is_root_pe +logical function is_root_pe() is_root_pe = .false. if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. end function is_root_pe From 2f5a0c8f361a86782a90df0ae8352bb43231bde4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 28 Jan 2021 17:24:55 -0500 Subject: [PATCH 181/212] +Partial consolidation of netcdf calls in MOM_io Took preliminary steps to consolidate the direct calls to netcdf in MOM_io.F90. Renamed check_grid_def to verify_variable_units and moved it to MOM_io, where it can be used more widely than just in MOM_regridding.F90. Also split get_var_sizes and get_varid out of num_timelevels and made them publicly visible. All answers are bitwise identical, but there are new public interfaces and the renaming of one routine. --- src/ALE/MOM_regridding.F90 | 61 +-------- src/framework/MOM_io.F90 | 258 ++++++++++++++++++++++++++----------- 2 files changed, 186 insertions(+), 133 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index dc85fab7d3..fedecd13a5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -6,7 +6,7 @@ module MOM_regridding use MOM_error_handler, only : MOM_error, FATAL, WARNING 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 : slasher +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 use MOM_verticalGrid, only : verticalGrid_type @@ -30,9 +30,6 @@ module MOM_regridding 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 -! Direct netcdf calls are used by check_grid_def() -use netcdf, only : NF90_open, NF90_inq_varid, NF90_get_att, NF90_NOERR, NF90_NOWRITE - implicit none ; private #include @@ -371,7 +368,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif if (index(trim(varName),'interfaces=')==1) then varName=trim(varName(12:)) - call check_grid_def(filename, varName, expected_units, message, ierr) + call verify_variable_units(filename, varName, expected_units, message, ierr) if (ierr) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "//& "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) @@ -734,61 +731,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (allocated(dz)) deallocate(dz) end subroutine initialize_regridding -!> Do some basic checks on the vertical grid definition file, variable -subroutine check_grid_def(filename, varname, expected_units, msg, ierr) - character(len=*), intent(in) :: filename !< File name - character(len=*), intent(in) :: varname !< Variable name - character(len=*), intent(in) :: expected_units !< Expected units of variable - character(len=*), intent(inout) :: msg !< Message to use for errors - logical, intent(out) :: ierr !< True if an error occurs - ! Local variables - character (len=200) :: units, long_name - integer :: ncid, status, intid, vid - integer :: i - - ierr = .false. - status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - ierr = .true. - msg = 'File not found: '//trim(filename) - return - endif - - status = NF90_INQ_VARID(ncid, trim(varname), vid) - if (status /= NF90_NOERR) then - ierr = .true. - msg = 'Var not found: '//trim(varname) - return - endif - - status = NF90_GET_ATT(ncid, vid, "units", units) - if (status /= NF90_NOERR) then - ierr = .true. - msg = 'Attribute not found: units' - return - endif - ! NF90_GET_ATT can return attributes with null characters, which TRIM will not truncate. - ! This loop replaces any null characters with a space so that the following check between - ! the read units and the expected units will pass - do i=1,LEN_TRIM(units) - if (units(i:i) == CHAR(0)) units(i:i) = " " - enddo - - if (trim(units) /= trim(expected_units)) then - if (trim(expected_units) == "meters") then - if (trim(units) /= "m") then - ierr = .true. - endif - else - ierr = .true. - endif - endif - - if (ierr) then - msg = 'Units incorrect: '//trim(units)//' /= '//trim(expected_units) - endif -end subroutine check_grid_def !> Deallocation of regridding memory subroutine end_regridding(CS) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index d990f2eea6..97fa290c51 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -26,15 +26,17 @@ module MOM_io use MOM_verticalGrid, only : verticalGrid_type use iso_fortran_env, only : stdout_iso=>output_unit, stderr_iso=>error_unit -use netcdf, only : NF90_open, NF90_inquire, NF90_inq_varids, NF90_inquire_variable -use netcdf, only : NF90_Inquire_Dimension, NF90_STRERROR, NF90_NOWRITE, NF90_NOERR +use netcdf, only : NF90_open, NF90_inq_varid, NF90_inq_varids, NF90_inquire, NF90_close +use netcdf, only : NF90_inquire_variable, NF90_get_att +use netcdf, only : NF90_Inquire_dimension, NF90_STRERROR, NF90_NOWRITE, NF90_NOERR implicit none ; private ! These interfaces are actually implemented in this file. -public :: create_file, reopen_file, num_timelevels, cmor_long_std, ensembler, MOM_io_init +public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc public :: open_namelist_file, check_namelist_error, check_nml_error +public :: get_var_sizes, verify_variable_units, num_timelevels, get_varid ! The following are simple pass throughs of routines from MOM_io_infra or other modules. public :: file_exists, open_file, close_file, flush_file, get_filename_appendix public :: get_file_info, field_exists, get_file_fields, get_file_times @@ -429,7 +431,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit end subroutine reopen_file -!> This function determines how many time levels a variable has. +!> This function determines how many time levels a variable has in a file. function num_timelevels(filename, varname, min_dims) result(n_time) character(len=*), intent(in) :: filename !< name of the file to read character(len=*), intent(in) :: varname !< variable whose number of time levels @@ -439,110 +441,218 @@ function num_timelevels(filename, varname, min_dims) result(n_time) !! dimension than this, then 0 is returned. integer :: n_time !< number of time levels varname has in filename - logical :: found - character(len=256) :: msg, name - integer :: ncid, nvars, status, varid, ndims, n - integer, allocatable :: varids(:), dimids(:) + character(len=256) :: msg + integer :: ncid, status, varid, ndims + integer :: sizes(8) n_time = -1 - found = .false. - ! To do almost the same via MOM_io_infra calls, do the following: + ! To do almost the same via MOM_io_infra calls, we could do the following: ! found = field_exists(filename, varname) - ! call open_file(ncid, filename, action=READONLY_FILE, form=NETCDF_FILE, threading=MULTIPLE) - ! call get_file_info(ncid, ntime=n_time) - ! However, this does not handle the case where the time axis for the variable is not the record axis. + ! if (found) then + ! call open_file(ncid, filename, action=READONLY_FILE, form=NETCDF_FILE, threading=MULTIPLE) + ! call get_file_info(ncid, ntime=n_time) + ! endif + ! However, this does not handle the case where the time axis for the variable is not the record + ! axis, it does not do a case-insensitive search for the variable, and min_dims is not used. - status = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - " Difficulties opening "//trim(filename)//" - "//trim(NF90_STRERROR(status))) - return + call get_var_sizes(filename, varname, ndims, sizes, match_case=.false.) + + 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.") + n_time = -1 + elseif (ndims == min_dims - 1) then + n_time = 0 + endif endif - status = NF90_INQUIRE(ncid, nVariables=nvars) +end function num_timelevels + + +!> get_var_sizes returns the number and size of dimensions associate with a variable in a file. +subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller) + character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages + character(len=*), intent(in) :: varname !< The variable name, used here for messages + integer, intent(out) :: ndims !< The number of dimensions to the variable + integer, dimension(:), intent(out) :: sizes !< The dimension sizes, or 0 for extra values + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + character(len=*), optional, intent(in) :: caller !< The name of a calling routine for use in error messages + + character(len=256) :: hdr + integer, allocatable :: dimids(:) + integer :: varid, ncid, n, status + + hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " + sizes(:) = 0 ; ndims = -1 + + status = NF90_open(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - " Difficulties getting the number of variables in file "//& - trim(filename)//" - "//trim(NF90_STRERROR(status))) + call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Difficulties opening "//trim(filename)) return endif - if (nvars < 1) then - call MOM_error(WARNING,"num_timelevels: "//& - " There appear not to be any variables in "//trim(filename)) + ! Get the dimension sizes of the variable varname. + call get_varid(varname, ncid, filename, varid, match_case=match_case) + if (varid < 0) return + + status = NF90_inquire_variable(ncid, varid, ndims=ndims) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting number of dimensions of "//trim(varname)//" in "//trim(filename)) return endif + if (ndims < 1) return - allocate(varids(nvars)) - - status = nf90_inq_varids(ncid, nvars, varids) + allocate(dimids(ndims)) + status = NF90_inquire_variable(ncid, varid, dimids=dimids(1:ndims)) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - " Difficulties getting the variable IDs in file "//& - trim(filename)//" - "//trim(NF90_STRERROR(status))) - deallocate(varids) ; return + call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting dimension IDs for "//trim(varname)//" in "//trim(filename)) + deallocate(dimids) ; return endif - do n = 1,nvars - status = nf90_inquire_variable(ncid, varids(n), name=name) + do n = 1, min(ndims,size(sizes)) + status = NF90_Inquire_Dimension(ncid, dimids(n), len=sizes(n)) + if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting dimension length for "//trim(varname)//" in "//trim(filename)) + enddo + deallocate(dimids) + + status = NF90_close(ncid) + if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Difficulties closing "//trim(filename)) + +end subroutine get_var_sizes + + +!> get_varid finds the netcdf handle for the potentially case-insensitive variable name in a file +subroutine get_varid(varname, ncid, filename, varid, match_case) + character(len=*), intent(in) :: varname !< The name of the variable that is being sought + integer, intent(in) :: ncid !< The open netcdf handle for the file + character(len=*), intent(in) :: filename !< name of the file to read, used here in messages + integer, intent(out) :: varid !< The netcdf handle for the variable + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + + logical :: found, insensitive + character(len=256) :: name + integer, allocatable :: varids(:) + integer :: nvars, status, n + + varid = -1 + found = .false. + insensitive = .false. ; if (present(match_case)) insensitive = .not.match_case + + if (insensitive) then + ! This code does a case-insensitive search for a variable in the file. + status = NF90_inquire(ncid, nVariables=nvars) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//& - " Difficulties getting a variable name in file "//& + call MOM_error(WARNING,"get_varid: Difficulties getting the number of variables in file "//& trim(filename)//" - "//trim(NF90_STRERROR(status))) + return endif - if (trim(lowercase(name)) == trim(lowercase(varname))) then - if (found) then - call MOM_error(WARNING, "num_timelevels: Two variables match the case-insensitive name "//& - trim(varname)//" in file "//trim(filename)) - else - varid = varids(n) ; found = .true. - endif + if (nvars < 1) then + call MOM_error(WARNING,"get_varid: There appear not to be any variables in "//trim(filename)) + return endif - enddo + allocate(varids(nvars)) - deallocate(varids) + status = nf90_inq_varids(ncid, nvars, varids) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, "get_varid: Difficulties getting the variable IDs in file "//& + trim(filename)//" - "//trim(NF90_STRERROR(status))) + deallocate(varids) ; return + endif - if (.not.found) then - call MOM_error(WARNING,"num_timelevels: "//& - " variable "//trim(varname)//" was not found in file "//trim(filename)) - return - endif + do n = 1,nvars + status = nf90_inquire_variable(ncid, varids(n), name=name) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, "get_varid: Difficulties getting a variable name in file "//& + trim(filename)//" - "//trim(NF90_STRERROR(status))) + endif - status = nf90_inquire_variable(ncid, varid, ndims = ndims) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//trim(NF90_STRERROR(status))//& - " Getting number of dimensions of "//trim(varname)//" in "//trim(filename)) - return - endif + if (trim(lowercase(name)) == trim(lowercase(varname))) then + if (found) then + call MOM_error(WARNING, "get_varid: Two variables match the case-insensitive name "//& + trim(varname)//" in file "//trim(filename)) + ! Replace the first variable if the second one is a case-sensitive match + if (trim(name) == trim(varname)) varid = varids(n) + else + varid = varids(n) ; found = .true. + endif + endif + enddo + if (.not.found) call MOM_error(WARNING, "get_varid: variable "//trim(varname)//& + " was not found in file "//trim(filename)) - 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.") - elseif (ndims == min_dims - 1) then - n_time = 0 ; return + deallocate(varids) + else + status = NF90_INQ_VARID(ncid, trim(varname), varid) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, "get_varid: Difficulties getting a variable id for "//& + trim(varname)//" in file "//trim(filename)//" - "//trim(NF90_STRERROR(status))) endif endif - allocate(dimids(ndims)) - status = nf90_inquire_variable(ncid, varid, dimids=dimids(1:ndims)) +end subroutine get_varid + +!> Verify that a file contains a named variable with the expected units. +subroutine verify_variable_units(filename, varname, expected_units, msg, ierr) + character(len=*), intent(in) :: filename !< File name + character(len=*), intent(in) :: varname !< Variable name + character(len=*), intent(in) :: expected_units !< Expected units of variable + character(len=*), intent(inout) :: msg !< Message to use for errors + logical, intent(out) :: ierr !< True if an error occurs + + ! Local variables + character (len=200) :: units + integer :: i, ncid, status, vid + + ierr = .true. + status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then - call MOM_error(WARNING,"num_timelevels: "//trim(NF90_STRERROR(status))//& - " Getting last dimension ID for "//trim(varname)//" in "//trim(filename)) - deallocate(dimids) ; return + msg = 'File not found: '//trim(filename) + return endif - status = nf90_Inquire_Dimension(ncid, dimids(ndims), len=n_time) - if (status /= NF90_NOERR) call MOM_error(WARNING,"num_timelevels: "//& - trim(NF90_STRERROR(status))//" Getting number of time levels of "//& - trim(varname)//" in "//trim(filename)) + status = NF90_INQ_VARID(ncid, trim(varname), vid) + if (status /= NF90_NOERR) then + msg = 'Var not found: '//trim(varname) + else + status = NF90_GET_ATT(ncid, vid, "units", units) + if (status /= NF90_NOERR) then + msg = 'Attribute not found: units' + else + ! NF90_GET_ATT can return attributes with null characters, which TRIM will not truncate. + ! This loop replaces any null characters with a space so that the subsequent check + ! between the read units and the expected units will pass + do i=1,LEN_TRIM(units) + if (units(i:i) == CHAR(0)) units(i:i) = " " + enddo + + if ((trim(units) == trim(expected_units)) .or. & + ((trim(expected_units) == "meters") .and. (trim(units) == "m"))) then + ierr = .false. + msg = '' + else + msg = 'Units incorrect: '//trim(units)//' /= '//trim(expected_units) + endif + endif + endif - deallocate(dimids) + status = NF90_close(ncid) -end function num_timelevels +end subroutine verify_variable_units !> Returns a vardesc type whose elements have been filled with the provided !! fields. The argument name is required, while the others are optional and From 14727e5998ca98326ba2d9d3e65c23998b51261a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 29 Jan 2021 11:03:06 -0500 Subject: [PATCH 182/212] +Only do reads from root_PE for get_var_sizes Modified get_var_sizes to have the root_PE do the reading and then broadcast this information to the other processors, unless directed not to via the new optional argument all_read. Part of this involved splitting read_var_sizes out from get_var_sizes. Also added the new optional argument alt_units to verify_variable_units, to give some flexibility when checking units without hard coding the "meters" to "m" comparison within verify_variable_units. --- src/ALE/MOM_regridding.F90 | 12 ++--- src/framework/MOM_io.F90 | 100 ++++++++++++++++++++++++++++++------- 2 files changed, 88 insertions(+), 24 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index fedecd13a5..1c6d9d4fe7 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -193,7 +193,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=40) :: coord_units, param_name, coord_res_param ! Temporary strings character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings - character(len=12) :: expected_units ! Temporary strings + character(len=12) :: expected_units, alt_units ! Temporary strings logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters logical :: coord_is_state_dependent, ierr logical :: default_2018_answers, remap_answers_2018 @@ -360,16 +360,16 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m !if (.not. field_exists(fileName,trim(varName))) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & ! "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (CS%regridding_scheme == REGRIDDING_SIGMA) then - expected_units = 'nondim' + expected_units = 'nondim' ; alt_units = expected_units elseif (CS%regridding_scheme == REGRIDDING_RHO) then - expected_units = 'kg m-3' + expected_units = 'kg m-3' ; alt_units = expected_units else - expected_units = 'meters' + expected_units = 'meters' ; alt_units = 'm' endif if (index(trim(varName),'interfaces=')==1) then varName=trim(varName(12:)) - call verify_variable_units(filename, varName, expected_units, message, ierr) - if (ierr) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "//& + call verify_variable_units(filename, varName, expected_units, message, ierr, alt_units) + if (ierr) call MOM_error(FATAL, trim(mdl)//", initialize_regridding: "//& "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 97fa290c51..3d12113b3a 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -4,11 +4,11 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : allocate_rotated_array, rotate_array -use MOM_domains, only : MOM_domain_type, domain1D, get_domain_components +use MOM_domains, only : MOM_domain_type, domain1D, broadcast, get_domain_components use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_ensemble_manager, only : get_ensemble_id -use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING, is_root_PE use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io_infra, only : MOM_read_data, MOM_read_vector, read_field_chksum @@ -456,7 +456,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) ! However, this does not handle the case where the time axis for the variable is not the record ! axis, it does not do a case-insensitive search for the variable, and min_dims is not used. - call get_var_sizes(filename, varname, ndims, sizes, match_case=.false.) + call get_var_sizes(filename, varname, ndims, sizes, match_case=.false., caller="num_timelevels") n_time = sizes(ndims) @@ -475,7 +475,50 @@ end function num_timelevels !> get_var_sizes returns the number and size of dimensions associate with a variable in a file. -subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller) +!! Usually only the root PE does the read, and then the information is broadcast +subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read) + character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages + character(len=*), intent(in) :: varname !< The variable name, used here for messages + integer, intent(out) :: ndims !< The number of dimensions to the variable + integer, dimension(:), intent(out) :: sizes !< The dimension sizes, or 0 for extra values + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + character(len=*), optional, intent(in) :: caller !< The name of a calling routine for use in error messages + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then it broadcasts the results. + + logical :: do_read, do_broadcast + integer, allocatable :: size_msg(:) ! An array combining the number of dimensions and the sizes. + integer :: n, nval + + do_read = is_root_pe() + if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller) + + if (do_broadcast) then + ! Distribute the sizes from the root PE. + nval = size(sizes) + 1 + + allocate(size_msg(nval)) + size_msg(1) = ndims + do n=2,nval ; size_msg(n) = sizes(n-1) ; enddo + + call broadcast(size_msg, nval, blocking=.true.) + + ndims = size_msg(1) + do n=2,nval ; sizes(n-1) = size_msg(n) ; enddo + deallocate(size_msg) + endif + +end subroutine get_var_sizes + +!> read_var_sizes returns the number and size of dimensions associate with a variable in a file. +!! Every processor for which this is called does the reading. +subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages character(len=*), intent(in) :: varname !< The variable name, used here for messages integer, intent(out) :: ndims !< The number of dimensions to the variable @@ -488,7 +531,6 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller) character(len=256) :: hdr integer, allocatable :: dimids(:) integer :: varid, ncid, n, status - hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " sizes(:) = 0 ; ndims = -1 @@ -530,7 +572,7 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller) if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& " Difficulties closing "//trim(filename)) -end subroutine get_var_sizes +end subroutine read_var_sizes !> get_varid finds the netcdf handle for the potentially case-insensitive variable name in a file @@ -607,17 +649,23 @@ subroutine get_varid(varname, ncid, filename, varid, match_case) end subroutine get_varid !> Verify that a file contains a named variable with the expected units. -subroutine verify_variable_units(filename, varname, expected_units, msg, ierr) - character(len=*), intent(in) :: filename !< File name - character(len=*), intent(in) :: varname !< Variable name - character(len=*), intent(in) :: expected_units !< Expected units of variable - character(len=*), intent(inout) :: msg !< Message to use for errors - logical, intent(out) :: ierr !< True if an error occurs +subroutine verify_variable_units(filename, varname, expected_units, msg, ierr, alt_units) + character(len=*), intent(in) :: filename !< File name + character(len=*), intent(in) :: varname !< Variable name + character(len=*), intent(in) :: expected_units !< Expected units of variable + character(len=*), intent(inout) :: msg !< Message to use for errors + logical, intent(out) :: ierr !< True if an error occurs + character(len=*), optional, intent(in) :: alt_units !< Alterate acceptable units of variable ! Local variables character (len=200) :: units + logical :: units_correct integer :: i, ncid, status, vid + if (.not.is_root_pe()) then ! Only the root PE should do the verification. + ierr = .false. ; msg = '' ; return + endif + ierr = .true. status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then @@ -640,8 +688,11 @@ subroutine verify_variable_units(filename, varname, expected_units, msg, ierr) if (units(i:i) == CHAR(0)) units(i:i) = " " enddo - if ((trim(units) == trim(expected_units)) .or. & - ((trim(expected_units) == "meters") .and. (trim(units) == "m"))) then + units_correct = (trim(units) == trim(expected_units)) + if (present(alt_units)) then + units_correct = units_correct .or. (trim(units) == trim(alt_units)) + endif + if (units_correct) then ierr = .false. msg = '' else @@ -690,7 +741,7 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, & - cmor_field_name=cmor_field_name,cmor_units=cmor_units, & + cmor_field_name=cmor_field_name, cmor_units=cmor_units, & cmor_longname=cmor_longname, conversion=conversion, caller=cllr) end function var_desc @@ -912,7 +963,7 @@ subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) end subroutine MOM_write_field_0d !> Given filename and fieldname, this subroutine returns the size of the field in the file -subroutine field_size(filename, fieldname, sizes, field_found, no_domain) +subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension @@ -920,9 +971,22 @@ subroutine field_size(filename, fieldname, sizes, field_found, no_domain) !! the input file. Without this argument, there !! is a fatal error if the field is not found. logical, optional, intent(in) :: no_domain !< If present and true, do not check for file - !! names with an appended tile number + !! names with an appended tile number. If + !! ndims is present, the default changes to true. + integer, optional, intent(out) :: ndims !< The number of dimensions to the variable - call get_field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + if (present(ndims)) then + if (present(no_domain)) then ; if (.not.no_domain) call MOM_error(FATAL, & + "field_size does not support the ndims argument when no_domain is present and false.") + endif + call get_var_sizes(filename, fieldname, ndims, sizes, match_case=.false.) + if (present(field_found)) field_found = (ndims >= 0) + if ((ndims < 0) .and. .not.present(field_found)) then + call MOM_error(FATAL, "Variable "//trim(fieldname)//" not found in "//trim(filename) ) + endif + else + call get_field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + endif end subroutine field_size From 199a453126373c0935caf29f9a78cde3b4d382a1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 Jan 2021 10:46:55 -0500 Subject: [PATCH 183/212] (*)Corrected bug in field_chksum When the field_chksum interfaces was added, it returned integers, but the set of mpp_chksum routines from FMS it wraps return 64-bit integers, not 32-bit integers. For small domain sizes (like in the TC tests) this is not a problem, but for much larger problems (like tides_025), this results in a truncation of the results and a change in the checksums, which in turn causes the model to fail if it tries to read a depth-list file. This commit restores the model behavior prior to MOM6 PR#1299 (commit# 797b1958..). All answers are bitwise identical in cases that worked with the previous version of the code, but some depth-list files that were created with MOM6 code after that commit may have incorrect verification checksums that lead to spurious fatal errors and should be deleted. --- src/framework/MOM_coms_infra.F90 | 36 ++++++++++++++++---------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/framework/MOM_coms_infra.F90 b/src/framework/MOM_coms_infra.F90 index f83785dd7b..e204b753f6 100644 --- a/src/framework/MOM_coms_infra.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -236,10 +236,10 @@ end subroutine broadcast_real2D !> Compute a checksum for a field distributed over a PE list. If no PE list is !! provided, then the current active PE list is used. function field_chksum_real_0d(field, pelist, mask_val) result(chksum) - real, intent(in) :: field !< Input scalar + real, intent(in) :: field !< Input scalar integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value - integer :: chksum !< checksum of array + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array chksum = mpp_chksum(field, pelist, mask_val) end function field_chksum_real_0d @@ -248,9 +248,9 @@ end function field_chksum_real_0d !! provided, then the current active PE list is used. function field_chksum_real_1d(field, pelist, mask_val) result(chksum) real, dimension(:), intent(in) :: field !< Input array - integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value - integer :: chksum !< checksum of array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array chksum = mpp_chksum(field, pelist, mask_val) end function field_chksum_real_1d @@ -258,10 +258,10 @@ end function field_chksum_real_1d !> Compute a checksum for a field distributed over a PE list. If no PE list is !! provided, then the current active PE list is used. function field_chksum_real_2d(field, pelist, mask_val) result(chksum) - real, dimension(:,:), intent(in) :: field !< Unrotated input field - integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value - integer :: chksum !< checksum of array + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array chksum = mpp_chksum(field, pelist, mask_val) end function field_chksum_real_2d @@ -269,10 +269,10 @@ end function field_chksum_real_2d !> Compute a checksum for a field distributed over a PE list. If no PE list is !! provided, then the current active PE list is used. function field_chksum_real_3d(field, pelist, mask_val) result(chksum) - real, dimension(:,:,:), intent(in) :: field !< Unrotated input field - integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value - integer :: chksum !< checksum of array + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array chksum = mpp_chksum(field, pelist, mask_val) end function field_chksum_real_3d @@ -280,10 +280,10 @@ end function field_chksum_real_3d !> Compute a checksum for a field distributed over a PE list. If no PE list is !! provided, then the current active PE list is used. function field_chksum_real_4d(field, pelist, mask_val) result(chksum) - real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field - integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value - integer :: chksum !< checksum of array + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array chksum = mpp_chksum(field, pelist, mask_val) end function field_chksum_real_4d From 3f69a40d78e6f5088737a94aab63df959de15c31 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sat, 30 Jan 2021 17:23:58 -0500 Subject: [PATCH 184/212] MOM_domain_infra: Document FMS passthroughs This patch explicitly identifies `global_field_sum` and `group_pass_type` as FMS pass-throughs. These remain undocumented and cannot be wrapped, but the exceptional reasons for retaining them justifies their existence as pass-throughs. Since `global_field_sum` is unused in MOM6/src, it does not require an explicit definition or wrapper. Legacy drivers may still require this definition, however, so we retain it here. The contents of `group_pass_type` are never accessed, and it is only used to facilitate internal mpp operations, so it does not need to formally be part of the MOM6 API and can be left undocumented. Since these two functions are exceptions to the rule that all active operations should be wrapped and documented, it makes sense to explicitly identify them as such. --- src/framework/MOM_domain_infra.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index d980c48317..68385b1c6d 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -7,11 +7,11 @@ module MOM_domain_infra use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL -use mpp_domains_mod, only : domain2D, domain1D, group_pass_type => mpp_group_update_type +use mpp_domains_mod, only : domain2D, domain1D use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain -use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains, global_field_sum => mpp_global_sum +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains 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 @@ -26,6 +26,12 @@ module MOM_domain_infra use fms_io_mod, only : file_exist, 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 +use mpp_domains_mod, only : global_field_sum => mpp_global_sum + +! The `group_pass_type` fields are never accessed, so we keep it as an FMS type +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type + implicit none ; private ! These types are inherited from mpp, but are treated as opaque here. From 8c01d0e10be9d8cf560cd1fc3492919acf306c06 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Jan 2021 19:38:27 -0500 Subject: [PATCH 185/212] +Added read_variable and read_attribute to MOM_io Added the new set of routines read_variable to do a simple read of an entire array from a netCDF file with the root PE, and then broadcast this information to the other PEs. Also added read_attribute to read a global or variable attribute. The option to read dimension names was added to get_var_sizes, and the option for get_varid to indicate whether a variable has been found. As a part of this, separate variants of broadcast were added for 32-bit and 64-bit integers, as were new variants of MOM_read_data for 1-d and 0-d integer fields. All answers are bitwise identical, but there are new options and optional arguments for overloaded interface, and there are two new overloaded interfaces for reading. --- src/framework/MOM_coms_infra.F90 | 29 +- src/framework/MOM_io.F90 | 457 ++++++++++++++++++++++++++++--- src/framework/MOM_io_infra.F90 | 41 ++- 3 files changed, 476 insertions(+), 51 deletions(-) diff --git a/src/framework/MOM_coms_infra.F90 b/src/framework/MOM_coms_infra.F90 index e204b753f6..6ead560537 100644 --- a/src/framework/MOM_coms_infra.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -23,7 +23,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast - module procedure broadcast_char, broadcast_int0D, broadcast_int1D + module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D end interface broadcast @@ -129,8 +129,8 @@ subroutine broadcast_char(dat, length, from_PE, PElist, blocking) end subroutine broadcast_char !> Communicate an integer from one PE to others -subroutine broadcast_int0D(dat, from_PE, PElist, blocking) - integer, intent(inout) :: dat !< The data to communicate and destination +subroutine broadcast_int64_0D(dat, from_PE, PElist, blocking) + integer(kind=int64), intent(inout) :: dat !< The data to communicate and destination 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. @@ -146,7 +146,28 @@ subroutine broadcast_int0D(dat, from_PE, PElist, blocking) call mpp_broadcast(dat, src_PE, PElist) if (do_block) call mpp_sync_self(PElist) -end subroutine broadcast_int0D +end subroutine broadcast_int64_0D + + +!> Communicate an integer from one PE to others +subroutine broadcast_int32_0D(dat, from_PE, PElist, blocking) + integer(kind=int32), intent(inout) :: dat !< The data to communicate and destination + 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, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int32_0D !> Communicate a 1-D array of integers from one PE to others subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 3d12113b3a..4385d62b1f 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -25,10 +25,11 @@ module MOM_io use MOM_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type -use iso_fortran_env, only : stdout_iso=>output_unit, stderr_iso=>error_unit +use iso_fortran_env, only : int32, int64, stdout_iso=>output_unit, stderr_iso=>error_unit use netcdf, only : NF90_open, NF90_inq_varid, NF90_inq_varids, NF90_inquire, NF90_close -use netcdf, only : NF90_inquire_variable, NF90_get_att -use netcdf, only : NF90_Inquire_dimension, NF90_STRERROR, NF90_NOWRITE, NF90_NOERR +use netcdf, only : NF90_inquire_variable, NF90_get_var, NF90_get_att +use netcdf, only : NF90_strerror, NF90_Inquire_dimension, NF90_get_att +use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT implicit none ; private @@ -36,7 +37,7 @@ module MOM_io public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc public :: open_namelist_file, check_namelist_error, check_nml_error -public :: get_var_sizes, verify_variable_units, num_timelevels, get_varid +public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute ! The following are simple pass throughs of routines from MOM_io_infra or other modules. public :: file_exists, open_file, close_file, flush_file, get_filename_appendix public :: get_file_info, field_exists, get_file_fields, get_file_times @@ -65,6 +66,18 @@ module MOM_io module procedure MOM_write_field_0d end interface MOM_write_field +!> Read an entire named variable from a named netCDF file using netCDF calls directly, rather +!! than any infrastructure routines and broadcast it from the root PE to the other PEs. +interface read_variable + module procedure read_variable_0d, read_variable_0d_int + module procedure read_variable_1d, read_variable_1d_int +end interface read_variable + +interface read_attribute + module procedure read_attribute_str, read_attribute_real + module procedure read_attribute_int32, read_attribute_int64 +end interface read_attribute + !> Type for describing a 3-d variable for output type, public :: vardesc character(len=64) :: name !< Variable name in a NetCDF file @@ -107,7 +120,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit 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=8), optional, intent(in) :: checksums(:,:) !< checksums of vars + integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars logical :: use_lath, use_lonh, use_latq, use_lonq, use_time logical :: use_layer, use_int, use_periodic @@ -454,7 +467,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) ! call get_file_info(ncid, ntime=n_time) ! endif ! However, this does not handle the case where the time axis for the variable is not the record - ! axis, it does not do a case-insensitive search for the variable, and min_dims is not used. + ! axis and min_dims is not used. call get_var_sizes(filename, varname, ndims, sizes, match_case=.false., caller="num_timelevels") @@ -476,7 +489,7 @@ end function num_timelevels !> get_var_sizes returns the number and size of dimensions associate with a variable in a file. !! Usually only the root PE does the read, and then the information is broadcast -subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read) +subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read, dim_names) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages character(len=*), intent(in) :: varname !< The variable name, used here for messages integer, intent(out) :: ndims !< The number of dimensions to the variable @@ -488,6 +501,8 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this !! routine actually do the read, otherwise only !! root PE reads and then it broadcasts the results. + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions for this variable logical :: do_read, do_broadcast integer, allocatable :: size_msg(:) ! An array combining the number of dimensions and the sizes. @@ -497,7 +512,7 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller) + if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names) if (do_broadcast) then ! Distribute the sizes from the root PE. @@ -512,13 +527,18 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al ndims = size_msg(1) do n=2,nval ; sizes(n-1) = size_msg(n) ; enddo deallocate(size_msg) + + if (present(dim_names)) then + nval = min(ndims, size(dim_names)) + call broadcast(dim_names(1:nval), len(dim_names(1)), blocking=.true.) + endif endif end subroutine get_var_sizes !> read_var_sizes returns the number and size of dimensions associate with a variable in a file. !! Every processor for which this is called does the reading. -subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller) +subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages character(len=*), intent(in) :: varname !< The variable name, used here for messages integer, intent(out) :: ndims !< The number of dimensions to the variable @@ -526,20 +546,20 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller) logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be !! case insensitive, but take a perfect match if !! found. The default is true. - character(len=*), optional, intent(in) :: caller !< The name of a calling routine for use in error messages + character(len=*), & + optional, intent(in) :: caller !< The name of a calling routine for use in error messages + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions for this variable - character(len=256) :: hdr + character(len=256) :: hdr, dimname integer, allocatable :: dimids(:) integer :: varid, ncid, n, status + logical :: success hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " sizes(:) = 0 ; ndims = -1 - status = NF90_open(filename, NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& - " Difficulties opening "//trim(filename)) - return - endif + call open_file_to_read(filename, ncid, success=success) + if (.not.success) return ! Get the dimension sizes of the variable varname. call get_varid(varname, ncid, filename, varid, match_case=match_case) @@ -562,9 +582,12 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller) endif do n = 1, min(ndims,size(sizes)) - status = NF90_Inquire_Dimension(ncid, dimids(n), len=sizes(n)) + status = NF90_Inquire_Dimension(ncid, dimids(n), name=dimname, len=sizes(n)) if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& " Getting dimension length for "//trim(varname)//" in "//trim(filename)) + if (present(dim_names)) then + if (n <= size(dim_names)) dim_names = trim(dimname) + endif enddo deallocate(dimids) @@ -574,9 +597,363 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller) end subroutine read_var_sizes +!> Read a real scalar variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_0d(filename, varname, var) + 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 + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_0d" + + if (is_root_pe()) then + call open_file_to_read(filename, ncid) + + 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)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + rc = NF90_close(ncid) + endif + + call broadcast(var, blocking=.true.) +end subroutine read_variable_0d + +!> Read a 1-d real variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_1d(filename, varname, var) + 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 + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_1d" + + if (is_root_pe()) then + call open_file_to_read(filename, ncid) + + 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)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + rc = NF90_close(ncid) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_1d + +!> Read a integer scalar variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_0d_int(filename, varname, var) + 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 + integer, intent(inout) :: var !< The scalar into which to read the data + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_0d_int" + + if (is_root_pe()) then + call open_file_to_read(filename, ncid) + + 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)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + rc = NF90_close(ncid) + endif + + call broadcast(var, blocking=.true.) +end subroutine read_variable_0d_int + +!> Read a 1-d integer variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_1d_int(filename, varname, var) + 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 + integer, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_1d_int" + + if (is_root_pe()) then + call open_file_to_read(filename, ncid) + + 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)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + rc = NF90_close(ncid) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_1d_int + +!> Read a character-string global or variable attribute +subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + character(len=*), intent(out) :: att_val !< The value of the attribute + 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 + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + character(len=len(att_val)) :: tmp_str(1) + hdr = "read_attribute_str" + att_val = "" + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + rc = NF90_close(ncid) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + ! These copies are here because broadcast only supports arrays of strings. + tmp_str(1) = att_val + call broadcast(tmp_str, len(att_val), blocking=.true.) + att_val = tmp_str(1) + if (present(found)) found = (is_found /= 0) + endif +end subroutine read_attribute_str + + +!> Read a 32-bit integer global or variable attribute +subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_read) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + integer(kind=int32), intent(out) :: att_val !< The value of the attribute + 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 + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_int32" + att_val = 0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + rc = NF90_close(ncid) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_int32 + + +!> Read a 64-bit integer global or variable attribute +subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_read) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + integer(kind=int64), intent(out) :: att_val !< The value of the attribute + 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 + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_int64" + att_val = 0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + rc = NF90_close(ncid) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_int64 + +!> Read a real global or variable attribute +subroutine read_attribute_real(filename, attname, att_val, varname, found, all_read) + 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 + 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 + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_real" + att_val = 0.0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + rc = NF90_close(ncid) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_real + +!> Open a netcdf file for reading, with error handling +subroutine open_file_to_read(filename, ncid, success) + character(len=*), intent(in) :: filename !< path and name of the file to open for reading + integer, intent(out) :: ncid !< The netcdf handle for the file + logical, optional, intent(out) :: success !< Returns true if the file was opened, or if this + !! argument is not present, failure is fatal error. + ! Local variables + integer rc + + rc = NF90_open(trim(filename), NF90_NOWRITE, ncid) + if (present(success)) then + success = (rc == NF90_NOERR) + elseif (rc /= NF90_NOERR) then + call MOM_error(FATAL, "Difficulties opening "//trim(filename)//" - "//trim(NF90_STRERROR(rc)) ) + endif + +end subroutine open_file_to_read !> get_varid finds the netcdf handle for the potentially case-insensitive variable name in a file -subroutine get_varid(varname, ncid, filename, varid, match_case) +subroutine get_varid(varname, ncid, filename, varid, match_case, found) character(len=*), intent(in) :: varname !< The name of the variable that is being sought integer, intent(in) :: ncid !< The open netcdf handle for the file character(len=*), intent(in) :: filename !< name of the file to read, used here in messages @@ -584,36 +961,36 @@ subroutine get_varid(varname, ncid, filename, varid, match_case) logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be !! case insensitive, but take a perfect match if !! found. The default is true. + logical, optional, intent(out) :: found !< Returns true if the attribute is found - logical :: found, insensitive + logical :: var_found, insensitive character(len=256) :: name integer, allocatable :: varids(:) integer :: nvars, status, n varid = -1 - found = .false. + var_found = .false. insensitive = .false. ; if (present(match_case)) insensitive = .not.match_case if (insensitive) then - ! This code does a case-insensitive search for a variable in the file. + ! This code ounddoes a case-insensitive search for a variable in the file. status = NF90_inquire(ncid, nVariables=nvars) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"get_varid: Difficulties getting the number of variables in file "//& + if (present(found) .and. ((status /= NF90_NOERR) .or. (nvars < 1))) then + found = .false. ; return + elseif (status /= NF90_NOERR) then + call MOM_error(FATAL, "get_varid: Difficulties getting the number of variables in file "//& trim(filename)//" - "//trim(NF90_STRERROR(status))) - return + elseif (nvars < 1) then + call MOM_error(FATAL, "get_varid: There appear not to be any variables in "//trim(filename)) endif - if (nvars < 1) then - call MOM_error(WARNING,"get_varid: There appear not to be any variables in "//trim(filename)) - return - endif allocate(varids(nvars)) status = nf90_inq_varids(ncid, nvars, varids) if (status /= NF90_NOERR) then call MOM_error(WARNING, "get_varid: Difficulties getting the variable IDs in file "//& trim(filename)//" - "//trim(NF90_STRERROR(status))) - deallocate(varids) ; return + nvars = -1 ! Full error handling will occur after the do-loop. endif do n = 1,nvars @@ -624,24 +1001,26 @@ subroutine get_varid(varname, ncid, filename, varid, match_case) endif if (trim(lowercase(name)) == trim(lowercase(varname))) then - if (found) then + if (var_found) then call MOM_error(WARNING, "get_varid: Two variables match the case-insensitive name "//& trim(varname)//" in file "//trim(filename)) ! Replace the first variable if the second one is a case-sensitive match if (trim(name) == trim(varname)) varid = varids(n) else - varid = varids(n) ; found = .true. + varid = varids(n) ; var_found = .true. endif endif enddo - if (.not.found) call MOM_error(WARNING, "get_varid: variable "//trim(varname)//& - " was not found in file "//trim(filename)) + if (present(found)) found = var_found + if ((.not.var_found) .and. .not.present(found)) call MOM_error(FATAL, & + "get_varid: variable "//trim(varname)//" was not found in file "//trim(filename)) deallocate(varids) else status = NF90_INQ_VARID(ncid, trim(varname), varid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING, "get_varid: Difficulties getting a variable id for "//& + if (present(found)) found = (status == NF90_NOERR) + if ((status /= NF90_NOERR) .and. .not.present(found)) then + call MOM_error(FATAL, "get_varid: Difficulties getting a variable id for "//& trim(varname)//" in file "//trim(filename)//" - "//trim(NF90_STRERROR(status))) endif endif @@ -659,7 +1038,7 @@ subroutine verify_variable_units(filename, varname, expected_units, msg, ierr, a ! Local variables character (len=200) :: units - logical :: units_correct + logical :: units_correct, success integer :: i, ncid, status, vid if (.not.is_root_pe()) then ! Only the root PE should do the verification. @@ -667,8 +1046,8 @@ subroutine verify_variable_units(filename, varname, expected_units, msg, ierr, a endif ierr = .true. - status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then + call open_file_to_read(filename, ncid, success) + if (.not.success) then msg = 'File not found: '//trim(filename) return endif diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index d7d744e740..8ae45e4903 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -23,6 +23,7 @@ module MOM_io_infra use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY use mpp_io_mod, only : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY +use iso_fortran_env, only : int64 implicit none ; private @@ -51,8 +52,8 @@ module MOM_io_infra module procedure MOM_read_data_4d module procedure MOM_read_data_3d module procedure MOM_read_data_2d, MOM_read_data_2d_region - module procedure MOM_read_data_1d - module procedure MOM_read_data_0d + module procedure MOM_read_data_1d, MOM_read_data_1d_int + module procedure MOM_read_data_0d, MOM_read_data_0d_int end interface !> Write a registered field to an output file @@ -81,11 +82,11 @@ module MOM_io_infra !> Reads the checksum value for a field that was recorded in a file, along with a flag indicating !! whether the file contained a valid checksum for this field. subroutine read_field_chksum(field, chksum, valid_chksum) - type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. - integer(kind=8), intent(out) :: chksum !< The checksum for the field. - logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + type(fieldtype), 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. ! Local variables - integer(kind=8), dimension(3) :: checksum_file + integer(kind=int64), dimension(3) :: checksum_file checksum_file(:) = -1 valid_chksum = mpp_attribute_exist(field, "checksum") @@ -268,7 +269,7 @@ subroutine get_field_atts(field, name, units, longname, checksum) 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=8), dimension(:), & + integer(kind=int64), dimension(:), & optional, intent(out) :: checksum !< The checksums of the variable in a file call mpp_get_atts(field, name=name, units=units, longname=longname, checksum=checksum) end subroutine get_field_atts @@ -469,6 +470,30 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_4d +!> This routine uses the fms_io subroutine read_data to read a scalar integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) + 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 + integer, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + +end subroutine MOM_read_data_0d_int + +!> This routine uses the fms_io subroutine read_data to read a 1-D integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) + 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 + integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + +end subroutine MOM_read_data_1d_int + !> This routine uses the fms_io subroutine read_data to read a pair of distributed !! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for @@ -672,7 +697,7 @@ subroutine write_metadata_field(unit, field, axes, name, units, longname, & !! 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=8), dimension(:), & + integer(kind=int64), dimension(:), & optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. From 953624267ed7f88b8773a1106ebd1528c5938643 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Jan 2021 19:43:19 -0500 Subject: [PATCH 186/212] Replace netCDF calls in read_depth_list Replaced the calls to netCDF in read_depth_list with calls to routines in MOM_io.F90 that accomplish the same thing. Also added trim calls to a number of error messages in write_depth_list_file. All answers and output are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 148 ++++++++--------------------- 1 file changed, 37 insertions(+), 111 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index ca57926ab1..ce380c109f 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -14,6 +14,7 @@ module MOM_sum_output use MOM_interface_heights, only : find_eta use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file, stdout use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix +use MOM_io, only : field_size, read_variable, read_attribute use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -26,10 +27,8 @@ module MOM_sum_output use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use netcdf, only : NF90_create, NF90_def_dim, NF90_def_var, NF90_put_att, NF90_enddef -use netcdf, only : NF90_put_var, NF90_open, NF90_close, NF90_inquire_variable, NF90_strerror -use netcdf, only : NF90_inq_varid, NF90_inquire_dimension, NF90_get_var, NF90_get_att -use netcdf, only : NF90_DOUBLE, NF90_NOERR, NF90_NOWRITE, NF90_GLOBAL, NF90_ENOTATT +use netcdf, only : NF90_create, NF90_def_dim, NF90_def_var, NF90_enddef, NF90_put_att, NF90_put_var +use netcdf, only : NF90_close, NF90_strerror, NF90_DOUBLE, NF90_NOERR, NF90_GLOBAL implicit none ; private @@ -1269,75 +1268,75 @@ subroutine write_depth_list(G, US, CS, filename, list_size) status = NF90_CREATE(filename, 0, ncid) if (status /= NF90_NOERR) then - call MOM_error(WARNING, filename//trim(NF90_STRERROR(status))) + call MOM_error(WARNING, trim(filename)//trim(NF90_STRERROR(status))) return endif status = NF90_DEF_DIM(ncid, "list", list_size, dimid(1)) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//trim(NF90_STRERROR(status))) + trim(filename)//trim(NF90_STRERROR(status))) status = NF90_DEF_VAR(ncid, "depth", NF90_DOUBLE, dimid, Did) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" depth "//trim(NF90_STRERROR(status))) + trim(filename)//" depth "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Did, "long_name", "Sorted depth") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" depth "//trim(NF90_STRERROR(status))) + trim(filename)//" depth "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Did, "units", "m") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" depth "//trim(NF90_STRERROR(status))) + trim(filename)//" depth "//trim(NF90_STRERROR(status))) status = NF90_DEF_VAR(ncid, "area", NF90_DOUBLE, dimid, Aid) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" area "//trim(NF90_STRERROR(status))) + trim(filename)//" area "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Aid, "long_name", "Open area at depth") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" area "//trim(NF90_STRERROR(status))) + trim(filename)//" area "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Aid, "units", "m2") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" area "//trim(NF90_STRERROR(status))) + trim(filename)//" area "//trim(NF90_STRERROR(status))) status = NF90_DEF_VAR(ncid, "vol_below", NF90_DOUBLE, dimid, Vid) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" vol_below "//trim(NF90_STRERROR(status))) + trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Vid, "long_name", "Open volume below depth") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" vol_below "//trim(NF90_STRERROR(status))) + trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, Vid, "units", "m3") if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" vol_below "//trim(NF90_STRERROR(status))) + trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) ! Dependency checksums status = NF90_PUT_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, depth_chksum) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) + trim(filename)//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) status = NF90_PUT_ATT(ncid, NF90_GLOBAL, area_chksum_attr, area_chksum) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) + trim(filename)//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) status = NF90_ENDDEF(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//trim(NF90_STRERROR(status))) + trim(filename)//trim(NF90_STRERROR(status))) do k=1,list_size ; tmp(k) = US%Z_to_m*CS%DL(k)%depth ; enddo status = NF90_PUT_VAR(ncid, Did, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" depth "//trim(NF90_STRERROR(status))) + trim(filename)//" depth "//trim(NF90_STRERROR(status))) do k=1,list_size ; tmp(k) = US%L_to_m**2*CS%DL(k)%area ; enddo status = NF90_PUT_VAR(ncid, Aid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" area "//trim(NF90_STRERROR(status))) + trim(filename)//" area "//trim(NF90_STRERROR(status))) do k=1,list_size ; tmp(k) = US%Z_to_m*US%L_to_m**2*CS%DL(k)%vol_below ; enddo status = NF90_PUT_VAR(ncid, Vid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//" vol_below "//trim(NF90_STRERROR(status))) + trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) status = NF90_CLOSE(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, & - filename//trim(NF90_STRERROR(status))) + trim(filename)//trim(NF90_STRERROR(status))) end subroutine write_depth_list @@ -1350,30 +1349,18 @@ subroutine read_depth_list(G, US, CS, filename) !! previous call to MOM_sum_output_init. character(len=*), intent(in) :: filename !< The path to the depth list file to read. ! Local variables - character(len=32) :: mdl - character(len=240) :: var_name, var_msg + character(len=240) :: var_msg real, allocatable :: tmp(:) - integer :: ncid, status, varid, list_size, k - integer :: ndim, len, var_dim_ids(8) + integer :: ncid, list_size, k, ndim, sizes(4) character(len=16) :: depth_file_chksum, depth_grid_chksum character(len=16) :: area_file_chksum, area_grid_chksum - integer :: depth_attr_status, area_attr_status + logical :: depth_att_found, area_att_found - mdl = "MOM_sum_output read_depth_list:" + ! Check bathymetric consistency between this configuration and the depth list file. + call read_attribute(filename, depth_chksum_attr, depth_file_chksum, found=depth_att_found) + call read_attribute(filename, area_chksum_attr, area_file_chksum, found=area_att_found) - status = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - call MOM_error(FATAL,mdl//" Difficulties opening "//trim(filename)// & - " - "//trim(NF90_STRERROR(status))) - endif - - ! Check bathymetric consistency - depth_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, & - depth_file_chksum) - area_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, area_chksum_attr, & - area_file_chksum) - - if (any([depth_attr_status, area_attr_status] == NF90_ENOTATT)) then + if ((.not.depth_att_found) .or. (.not.area_att_found)) then var_msg = trim(CS%depth_list_file) // " checksums are missing;" if (CS%require_depth_list_chksum) then call MOM_error(FATAL, trim(var_msg) // " aborting.") @@ -1387,25 +1374,9 @@ subroutine read_depth_list(G, US, CS, filename) trim(var_msg) // " some diagnostics may not be reproducible.") endif else - ! Validate netCDF call - if (depth_attr_status /= NF90_NOERR) then - var_msg = mdl // "Failed to read " // trim(filename) // ":" & - // depth_chksum_attr - call MOM_error(FATAL, & - trim(var_msg) // " - " // NF90_STRERROR(depth_attr_status)) - endif - - if (area_attr_status /= NF90_NOERR) then - var_msg = mdl // "Failed to read " // trim(filename) // ":" & - // area_chksum_attr - call MOM_error(FATAL, & - trim(var_msg) // " - " // NF90_STRERROR(area_attr_status)) - endif - call get_depth_list_checksums(G, depth_grid_chksum, area_grid_chksum) - if (depth_grid_chksum /= depth_file_chksum & - .or. area_grid_chksum /= area_file_chksum) then + if ((depth_grid_chksum /= depth_file_chksum) .or. (area_grid_chksum /= area_file_chksum)) then var_msg = trim(CS%depth_list_file) // " checksums do not match;" if (CS%require_depth_list_chksum) then call MOM_error(FATAL, trim(var_msg) // " aborting.") @@ -1415,75 +1386,30 @@ subroutine read_depth_list(G, US, CS, filename) call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) return else - call MOM_error(WARNING, & - trim(var_msg) // " some diagnostics may not be reproducible.") + call MOM_error(WARNING, trim(var_msg) // " some diagnostics may not be reproducible.") endif endif endif - var_name = "depth" - var_msg = trim(var_name)//" in "//trim(filename)//" - " - status = NF90_INQ_VARID(ncid, var_name, varid) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties finding variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - - status = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndim, dimids=var_dim_ids) - if (status /= NF90_NOERR) then - call MOM_ERROR(FATAL,mdl//" cannot inquire about "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - elseif (ndim > 1) then - call MOM_ERROR(FATAL,mdl//" "//trim(var_msg)//& - " has too many or too few dimensions.") - endif - ! Get the length of the list. - status = NF90_INQUIRE_DIMENSION(ncid, var_dim_ids(1), len=list_size) - if (status /= NF90_NOERR) call MOM_ERROR(FATAL,mdl// & - " cannot inquire about dimension(1) of "//trim(var_msg)//& - trim(NF90_STRERROR(status))) + call field_size(filename, "depth", sizes, ndims=ndim) + if (ndim /= 1) call MOM_ERROR(FATAL, "MOM_sum_output read_depth_list: depth in "//& + trim(filename)//" has too many or too few dimensions.") + list_size = sizes(1) CS%list_size = list_size-1 allocate(CS%DL(list_size)) allocate(tmp(list_size)) - status = NF90_GET_VAR(ncid, varid, tmp) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties reading variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - + call read_variable(filename, "depth", tmp) do k=1,list_size ; CS%DL(k)%depth = US%m_to_Z*tmp(k) ; enddo - var_name = "area" - var_msg = trim(var_name)//" in "//trim(filename)//" - " - status = NF90_INQ_VARID(ncid, var_name, varid) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties finding variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - status = NF90_GET_VAR(ncid, varid, tmp) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties reading variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - + call read_variable(filename, "area", tmp) do k=1,list_size ; CS%DL(k)%area = US%m_to_L**2*tmp(k) ; enddo - var_name = "vol_below" - var_msg = trim(var_name)//" in "//trim(filename) - status = NF90_INQ_VARID(ncid, var_name, varid) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties finding variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - status = NF90_GET_VAR(ncid, varid, tmp) - if (status /= NF90_NOERR) call MOM_error(FATAL,mdl// & - " Difficulties reading variable "//trim(var_msg)//& - trim(NF90_STRERROR(status))) - + call read_variable(filename, "vol_below", tmp) do k=1,list_size ; CS%DL(k)%vol_below = US%m_to_Z*US%m_to_L**2*tmp(k) ; enddo - status = NF90_CLOSE(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, mdl// & - " Difficulties closing "//trim(filename)//" - "//trim(NF90_STRERROR(status))) - deallocate(tmp) end subroutine read_depth_list From 3c3bda7539c4772439a3969bea480aa40f218528 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Jan 2021 19:48:58 -0500 Subject: [PATCH 187/212] Replace netCDF calls in MOM_shared_initialization Eliminated the direct netCDF calls in MOM_shared_initialization, replacing them with calls to routines in MOM_io. All answers are bitwise identical. --- .../MOM_shared_initialization.F90 | 96 +++++-------------- 1 file changed, 26 insertions(+), 70 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index d32f972258..ccf9436e14 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -11,15 +11,12 @@ 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, fieldtype, file_exists, stdout -use MOM_io, only : MOM_read_data, MOM_read_vector, SINGLE_FILE, MULTIPLE +use MOM_io, only : close_file, create_file, fieldtype, file_exists, field_size, stdout +use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use netcdf, only : NF90_open, NF90_inq_varid, NF90_get_var, NF90_close -use netcdf, only : NF90_inq_dimid, NF90_inquire_dimension, NF90_NOWRITE, NF90_NOERR - implicit none ; private public MOM_shared_init_init @@ -192,11 +189,12 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) ! Local variables real :: m_to_Z ! A dimensional rescaling factor. + real, dimension(:), allocatable :: new_depth ! The new values of the depths [m] + integer, dimension(:), allocatable :: ig, jg ! The global indicies of the points to modify character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. - integer :: n_edits, n, ashape(5), i, j, ncid, id, ncstatus, iid, jid, zid - integer, dimension(:), allocatable :: ig, jg - real, dimension(:), allocatable :: new_depth + integer :: i, j, n, n_edits, i_file, j_file, ndims, sizes(8) + logical :: found call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -211,72 +209,30 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) if (len_trim(topo_edits_file)==0) return topo_edits_file = trim(inputdir)//trim(topo_edits_file) - if (.not.file_exists(topo_edits_file, G%Domain)) call MOM_error(FATAL, & - 'initialize_topography_from_file: Unable to open '//trim(topo_edits_file)) + if (.not.file_exists(topo_edits_file, G%Domain)) & + call MOM_error(FATAL, trim(mdl)//': Unable to find file '//trim(topo_edits_file)) - ncstatus = nf90_open(trim(topo_edits_file), NF90_NOWRITE, ncid) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to open '//trim(topo_edits_file)) + ! Read and check the values of ni and nj in the file for consistency with this configuration. + call read_variable(topo_edits_file, 'ni', i_file) + call read_variable(topo_edits_file, 'nj', j_file) + if (i_file /= G%ieg) call MOM_error(FATAL, trim(mdl)//': Incompatible i-dimension of grid in '//& + trim(topo_edits_file)) + if (j_file /= G%jeg) call MOM_error(FATAL, trim(mdl)//': Incompatible j-dimension of grid in '//& + trim(topo_edits_file)) ! Get nEdits - ncstatus = nf90_inq_dimid(ncid, 'nEdits', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_dimid nEdits for '//trim(topo_edits_file)) - ncstatus = nf90_inquire_dimension(ncid, id, len=n_edits) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inquire_dimension nEdits for '//trim(topo_edits_file)) - - ! Read ni - ncstatus = nf90_inq_varid(ncid, 'ni', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_varid ni for '//trim(topo_edits_file)) - ncstatus = nf90_get_var(ncid, id, i) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to get_var ni for '//trim(topo_edits_file)) - if (i /= G%ieg) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Incompatible i-dimension of grid in '//trim(topo_edits_file)) - - ! Read nj - ncstatus = nf90_inq_varid(ncid, 'nj', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_varid nj for '//trim(topo_edits_file)) - ncstatus = nf90_get_var(ncid, id, j) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to get_var nj for '//trim(topo_edits_file)) - if (j /= G%jeg) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Incompatible j-dimension of grid in '//trim(topo_edits_file)) - - ! Read iEdit - ncstatus = nf90_inq_varid(ncid, 'iEdit', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_varid iEdit for '//trim(topo_edits_file)) + call field_size(topo_edits_file, 'zEdit', sizes, ndims=ndims) + if (ndims /= 1) call MOM_error(FATAL, "The variable zEdit has an "//& + "unexpected number of dimensions in "//trim(topo_edits_file) ) + n_edits = sizes(1) allocate(ig(n_edits)) - ncstatus = nf90_get_var(ncid, id, ig) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to get_var iEdit for '//trim(topo_edits_file)) - - ! Read jEdit - ncstatus = nf90_inq_varid(ncid, 'jEdit', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_varid jEdit for '//trim(topo_edits_file)) allocate(jg(n_edits)) - ncstatus = nf90_get_var(ncid, id, jg) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to get_var jEdit for '//trim(topo_edits_file)) - - ! Read zEdit - ncstatus = nf90_inq_varid(ncid, 'zEdit', id) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to inq_varid zEdit for '//trim(topo_edits_file)) allocate(new_depth(n_edits)) - ncstatus = nf90_get_var(ncid, id, new_depth) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to get_var zEdit for '//trim(topo_edits_file)) - ! Close file - ncstatus = nf90_close(ncid) - if (ncstatus /= NF90_NOERR) call MOM_error(FATAL, 'apply_topography_edits_from_file: '//& - 'Failed to close '//trim(topo_edits_file)) + ! Read iEdit, jEdit and zEdit + call read_variable(topo_edits_file, 'iEdit', ig) + call read_variable(topo_edits_file, 'jEdit', jg) + call read_variable(topo_edits_file, 'zEdit', new_depth) do n = 1, n_edits i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 @@ -284,11 +240,11 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then if (new_depth(n)/=0.) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)/m_to_Z,'->',abs(new_depth(n)),i,j + 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)/m_to_Z, '->', abs(new_depth(n)), i, j D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else - call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& - "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) + call MOM_error(FATAL, trim(mdl)//': A zero depth edit would change the land mask and '//& + "is not allowed in"//trim(topo_edits_file)) endif endif enddo From 44a8bde1c4ddcd1cdfbabcfe3c932a6cc966b791 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Jan 2021 19:52:16 -0500 Subject: [PATCH 188/212] Replace netCDF calls in MOM_tracer_Z_init Eliminated the direct netCDF calls in read_Z_edges in MOM_tracer_Z_init, replacing them with calls to routines in MOM_io. All answers are bitwise identical. --- src/tracer/MOM_tracer_Z_init.F90 | 94 +++++--------------------------- 1 file changed, 14 insertions(+), 80 deletions(-) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 8381c85538..14767d6cd4 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -6,15 +6,11 @@ module MOM_tracer_Z_init 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_io, only : MOM_read_data +use MOM_io, only : MOM_read_data, get_var_sizes, read_attribute, read_variable use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var -use netcdf, only : NF90_get_att, NF90_inquire_dimension, NF90_close, NF90_strerror -use netcdf, only : NF90_NOWRITE, NF90_NOERR - implicit none ; private #include @@ -402,98 +398,37 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & ! NetCDF file. It also might read the missing value attribute for that same field. character(len=32) :: mdl character(len=120) :: dim_name, edge_name, tr_msg, dim_msg + character(len=256) :: dim_names(4) logical :: monotonic integer :: ncid, status, intid, tr_id, layid, k - integer :: nz_edge, ndim, tr_dim_ids(8) + integer :: nz_edge, ndim, tr_dim_ids(8), sizes(4) mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) - status = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties opening "//trim(filename)//& - " - "//trim(NF90_STRERROR(status))) - nz_out = -1 ; return - endif - - status = NF90_INQ_VARID(ncid, tr_name, tr_id) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties finding variable "//& - trim(tr_msg)//" - "//trim(NF90_STRERROR(status))) - nz_out = -1 ; status = NF90_CLOSE(ncid) ; return - endif - status = NF90_INQUIRE_VARIABLE(ncid, tr_id, ndims=ndim, dimids=tr_dim_ids) - if (status /= NF90_NOERR) then - call MOM_ERROR(WARNING,mdl//" cannot inquire about "//trim(tr_msg)) - elseif ((ndim < 3) .or. (ndim > 4)) then - call MOM_ERROR(WARNING,mdl//" "//trim(tr_msg)//& - " has too many or too few dimensions.") - nz_out = -1 ; status = NF90_CLOSE(ncid) ; return - endif - - if (.not.use_missing) then - ! Try to find the missing value from the dataset. - status = NF90_GET_ATT(ncid, tr_id, "missing_value", missing) - if (status /= NF90_NOERR) use_missing = .true. - endif + call get_var_sizes(filename, tr_name, ndim, sizes, dim_names=dim_names) + if ((ndim < 3) .or. (ndim > 4)) & + call MOM_ERROR(FATAL, mdl//" "//trim(tr_msg)//" has too many or too few dimensions.") + nz_out = sizes(3) - ! Get the axis name and length. - status = NF90_INQUIRE_DIMENSION(ncid, tr_dim_ids(3), dim_name, len=nz_out) - if (status /= NF90_NOERR) then - call MOM_ERROR(WARNING,mdl//" cannot inquire about dimension(3) of "//& - trim(tr_msg)) - endif - - dim_msg = trim(dim_name)//" in "//trim(filename) - status = NF90_INQ_VARID(ncid, dim_name, layid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties finding variable "//& - trim(dim_msg)//" - "//trim(NF90_STRERROR(status))) - nz_out = -1 ; status = NF90_CLOSE(ncid) ; return + 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) endif ! Find out if the Z-axis has an edges attribute - status = NF90_GET_ATT(ncid, layid, "edges", edge_name) - if (status /= NF90_NOERR) then - call MOM_mesg(mdl//" "//trim(dim_msg)//& - " has no readable edges attribute - "//trim(NF90_STRERROR(status))) - has_edges = .false. - else - has_edges = .true. - status = NF90_INQ_VARID(ncid, edge_name, intid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties finding edge variable "//& - trim(edge_name)//" in "//trim(filename)//" - "//trim(NF90_STRERROR(status))) - has_edges = .false. - endif - endif + call read_attribute(filename, "edges", edge_name, varname=dim_names(3), found=has_edges) - nz_edge = nz_out ; if (has_edges) nz_edge = nz_out+1 + nz_edge = sizes(3) ; if (has_edges) nz_edge = sizes(3)+1 allocate(z_edges(nz_edge)) ; z_edges(:) = 0.0 if (nz_out < 1) return ! Read the right variable. if (has_edges) then - dim_msg = trim(edge_name)//" in "//trim(filename) - status = NF90_GET_VAR(ncid, intid, z_edges) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties reading variable "//& - trim(dim_msg)//" - "//trim(NF90_STRERROR(status))) - nz_out = -1 ; status = NF90_CLOSE(ncid) ; return - endif + call read_variable(filename, edge_name, z_edges) else - status = NF90_GET_VAR(ncid, layid, z_edges) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,mdl//" Difficulties reading variable "//& - trim(dim_msg)//" - "//trim(NF90_STRERROR(status))) - nz_out = -1 ; status = NF90_CLOSE(ncid) ; return - endif + call read_variable(filename, dim_names(3), z_edges) endif - status = NF90_CLOSE(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, mdl// & - " Difficulties closing "//trim(filename)//" - "//trim(NF90_STRERROR(status))) - ! z_edges should be montonically decreasing with our sign convention. ! Change the sign sign convention if it looks like z_edges is increasing. if (z_edges(1) < z_edges(2)) then @@ -502,8 +437,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & ! Check that z_edges is now monotonically decreasing. monotonic = .true. do k=2,nz_edge ; if (z_edges(k) >= z_edges(k-1)) monotonic = .false. ; enddo - if (.not.monotonic) & - call MOM_error(WARNING,mdl//" "//trim(dim_msg)//" is not monotonic.") + if (.not.monotonic) call MOM_error(WARNING,mdl//" "//trim(dim_msg)//" is not monotonic.") if (scale /= 1.0) then ; do k=1,nz_edge ; z_edges(k) = scale*z_edges(k) ; enddo ; endif From da14640e5e15f08f0d90939ca384ca4d888ca079 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Jan 2021 22:19:14 -0500 Subject: [PATCH 189/212] Added missing Doxygen comments for read_attribute Added the missing comments describing the new interface read_attribute. All answers are bitwise identical. --- src/framework/MOM_io.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 4385d62b1f..a49d174ad1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -73,6 +73,8 @@ module MOM_io module procedure read_variable_1d, read_variable_1d_int end interface read_variable +!> Read a global or variable attribute from a named netCDF file using netCDF calls +!! directly, in some cases reading from the root PE before broadcasting to the other PEs. interface read_attribute module procedure read_attribute_str, read_attribute_real module procedure read_attribute_int32, read_attribute_int64 From 3fed47abc2de090ca77fcfd632967bf307d5f45a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 1 Feb 2021 10:59:57 -0500 Subject: [PATCH 190/212] +read_attribute uses allocatable character string Modified read_attribute_str to work with allocatable character string arguments to properly handle string attributes of unknown (and possibly enormous) size, following advice from Keith Lindsay. Because this is a change in an argument to a (recently added) publicly visible interface, it required changes to the two places where it was called. All answers are bitwise identical, but an interface has changed. --- src/diagnostics/MOM_sum_output.F90 | 9 ++-- src/framework/MOM_io.F90 | 68 +++++++++++++++++++----------- src/tracer/MOM_tracer_Z_init.F90 | 4 +- 3 files changed, 52 insertions(+), 29 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index ce380c109f..14a4ceabe3 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1352,8 +1352,8 @@ subroutine read_depth_list(G, US, CS, filename) character(len=240) :: var_msg real, allocatable :: tmp(:) integer :: ncid, list_size, k, ndim, sizes(4) - character(len=16) :: depth_file_chksum, depth_grid_chksum - character(len=16) :: area_file_chksum, area_grid_chksum + character(len=:), allocatable :: depth_file_chksum, area_file_chksum + character(len=16) :: depth_grid_chksum, area_grid_chksum logical :: depth_att_found, area_att_found ! Check bathymetric consistency between this configuration and the depth list file. @@ -1376,7 +1376,8 @@ subroutine read_depth_list(G, US, CS, filename) else call get_depth_list_checksums(G, depth_grid_chksum, area_grid_chksum) - if ((depth_grid_chksum /= depth_file_chksum) .or. (area_grid_chksum /= area_file_chksum)) then + if ((trim(depth_grid_chksum) /= trim(depth_file_chksum)) .or. & + (trim(area_grid_chksum) /= trim(area_file_chksum)) ) then var_msg = trim(CS%depth_list_file) // " checksums do not match;" if (CS%require_depth_list_chksum) then call MOM_error(FATAL, trim(var_msg) // " aborting.") @@ -1390,6 +1391,8 @@ subroutine read_depth_list(G, US, CS, filename) endif endif endif + if (allocated(area_file_chksum)) deallocate(area_file_chksum) + if (allocated(depth_file_chksum)) deallocate(depth_file_chksum) ! Get the length of the list. call field_size(filename, "depth", sizes, ndims=ndim) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index a49d174ad1..4b323b506a 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -27,9 +27,9 @@ module MOM_io use iso_fortran_env, only : int32, int64, stdout_iso=>output_unit, stderr_iso=>error_unit use netcdf, only : NF90_open, NF90_inq_varid, NF90_inq_varids, NF90_inquire, NF90_close -use netcdf, only : NF90_inquire_variable, NF90_get_var, NF90_get_att -use netcdf, only : NF90_strerror, NF90_Inquire_dimension, NF90_get_att -use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT +use netcdf, only : NF90_inquire_variable, NF90_get_var, NF90_get_att, NF90_inquire_attribute +use netcdf, only : NF90_strerror, NF90_inquire_dimension +use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT, NF90_CHAR implicit none ; private @@ -711,7 +711,7 @@ end subroutine read_variable_1d_int subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read) character(len=*), intent(in) :: filename !< Name of the file to read character(len=*), intent(in) :: attname !< Name of the attribute to read - character(len=*), intent(out) :: att_val !< The value of the attribute + character(:), allocatable, intent(out) :: att_val !< The value of the attribute 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 @@ -720,11 +720,11 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re !! root PE reads and then broadcasts the results. logical :: do_read, do_broadcast - integer :: rc, ncid, varid, is_found - character(len=256) :: hdr - character(len=len(att_val)) :: tmp_str(1) + integer :: rc, ncid, varid, att_type, att_len, info(2) + character(len=256) :: hdr, att_str + character(len=:), dimension(:), allocatable :: tmp_str hdr = "read_attribute_str" - att_val = "" + att_len = 0 do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read @@ -733,20 +733,29 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re if (present(found)) then ; if (.not.found) do_read = .false. ; endif if (do_read) then - rc = NF90_ENOTATT + rc = NF90_ENOTATT ; att_len = 0 if (present(varname)) then ! Read a variable attribute call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) - if (varid >= 0) then ! The named variable does exist, and found would be true. + att_str = "att "//trim(attname)//" for "//trim(varname)//" from "//trim(filename) + else ! Read a global attribute + varid = NF90_GLOBAL + att_str = "global att "//trim(attname)//" from "//trim(filename) + endif + if ((varid > 0) .or. (varid == NF90_GLOBAL)) then ! The named variable does exist, and found would be true. + rc = NF90_inquire_attribute(ncid, varid, attname, xtype=att_type, len=att_len) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) + if (att_type /= NF90_CHAR) & + call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) +! if (att_len > len(att_val)) & +! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) + allocate(character(att_len) :: att_val) + + if (rc == NF90_NOERR) then rc = NF90_get_att(ncid, varid, attname, att_val) if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& - trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) endif - else ! Read a global attribute - rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) - if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& - " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) endif if (present(found)) found = (rc == NF90_NOERR) @@ -754,15 +763,24 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re endif if (do_broadcast) then - if (present(found)) then - is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 - call broadcast(is_found, blocking=.false.) + ! Communicate the string length + info(1) = att_len ; info(2) = 0 ; if (do_read .and. found) info(2) = 1 + call broadcast(info, 2, blocking=.true.) + att_len = info(1) + + if (att_len > 0) then + ! These extra copies are here because broadcast only supports arrays of strings. + allocate(character(att_len) :: tmp_str(1)) + if (.not.do_read) allocate(character(att_len) :: att_val) + if (do_read) tmp_str(1) = att_val + call broadcast(tmp_str, att_len, blocking=.true.) + att_val = tmp_str(1) + if (present(found)) found = (info(2) /= 0) + elseif (.not.allocated(att_val)) then + allocate(character(4) :: att_val) ; att_val = '' endif - ! These copies are here because broadcast only supports arrays of strings. - tmp_str(1) = att_val - call broadcast(tmp_str, len(att_val), blocking=.true.) - att_val = tmp_str(1) - if (present(found)) found = (is_found /= 0) + elseif (.not.allocated(att_val)) then + allocate(character(4) :: att_val) ; att_val = '' endif end subroutine read_attribute_str diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 14767d6cd4..17d72b7d99 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -397,7 +397,8 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & ! 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. character(len=32) :: mdl - character(len=120) :: dim_name, edge_name, tr_msg, dim_msg + character(len=120) :: dim_name, tr_msg, dim_msg + character(:), allocatable :: edge_name character(len=256) :: dim_names(4) logical :: monotonic integer :: ncid, status, intid, tr_id, layid, k @@ -428,6 +429,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & else call read_variable(filename, dim_names(3), z_edges) endif + if (allocated(edge_name)) deallocate(edge_name) ! z_edges should be montonically decreasing with our sign convention. ! Change the sign sign convention if it looks like z_edges is increasing. From 89392e3df9c67a7212277b10ba711a11db6cf43f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 1 Feb 2021 16:06:24 -0500 Subject: [PATCH 191/212] +Add ncid_in optional args to MOM_io read routines Added the option to provide a handle to an open netCDF file via the new ncid_in optional arguments to various routines that read from netCDF files. Along with the new interfaces open_file_to_read and close_file_to read in MOM_io these allow for files to be opened and closed once while reading a number of fields or attributes from the same file. If these arguments are not provided, the files are opened and closed with each call as before. All answers are bitwise identical, although there are new optional arguments and new public interfaces. --- src/framework/MOM_io.F90 | 173 +++++++++++++----- .../MOM_shared_initialization.F90 | 25 ++- src/tracer/MOM_tracer_Z_init.F90 | 18 +- 3 files changed, 156 insertions(+), 60 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 4b323b506a..050f24db27 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -38,6 +38,7 @@ module MOM_io public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc 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, close_file, flush_file, get_filename_appendix public :: get_file_info, field_exists, get_file_fields, get_file_times @@ -491,7 +492,7 @@ end function num_timelevels !> get_var_sizes returns the number and size of dimensions associate with a variable in a file. !! Usually only the root PE does the read, and then the information is broadcast -subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read, dim_names) +subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read, dim_names, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages character(len=*), intent(in) :: varname !< The variable name, used here for messages integer, intent(out) :: ndims !< The number of dimensions to the variable @@ -505,6 +506,8 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al !! root PE reads and then it broadcasts the results. character(len=*), dimension(:), & optional, intent(out) :: dim_names !< The names of the dimensions for this variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. logical :: do_read, do_broadcast integer, allocatable :: size_msg(:) ! An array combining the number of dimensions and the sizes. @@ -514,7 +517,7 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names) + if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) if (do_broadcast) then ! Distribute the sizes from the root PE. @@ -540,7 +543,7 @@ end subroutine get_var_sizes !> read_var_sizes returns the number and size of dimensions associate with a variable in a file. !! Every processor for which this is called does the reading. -subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names) +subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages character(len=*), intent(in) :: varname !< The variable name, used here for messages integer, intent(out) :: ndims !< The number of dimensions to the variable @@ -552,6 +555,8 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d optional, intent(in) :: caller !< The name of a calling routine for use in error messages character(len=*), dimension(:), & optional, intent(out) :: dim_names !< The names of the dimensions for this variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. character(len=256) :: hdr, dimname integer, allocatable :: dimids(:) @@ -560,8 +565,12 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " sizes(:) = 0 ; ndims = -1 - call open_file_to_read(filename, ncid, success=success) - if (.not.success) return + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=success) + if (.not.success) return + endif ! Get the dimension sizes of the variable varname. call get_varid(varname, ncid, filename, varid, match_case=match_case) @@ -593,25 +602,29 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d enddo deallocate(dimids) - status = NF90_close(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& - " Difficulties closing "//trim(filename)) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) end subroutine read_var_sizes !> Read a real scalar variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_0d(filename, varname, var) - 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 +subroutine read_variable_0d(filename, varname, var, ncid_in) + 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 + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. integer :: varid, ncid, rc character(len=256) :: hdr hdr = "read_variable_0d" if (is_root_pe()) then - call open_file_to_read(filename, ncid) + 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)//& @@ -620,7 +633,7 @@ subroutine read_variable_0d(filename, varname, var) if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& " Difficulties reading "//trim(varname)//" from "//trim(filename)) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif call broadcast(var, blocking=.true.) @@ -628,17 +641,23 @@ end subroutine read_variable_0d !> Read a 1-d real variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_1d(filename, varname, var) - 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 +subroutine read_variable_1d(filename, varname, var, ncid_in) + 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 + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. integer :: varid, ncid, rc character(len=256) :: hdr hdr = "read_variable_1d" if (is_root_pe()) then - call open_file_to_read(filename, ncid) + 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)//& @@ -647,7 +666,7 @@ subroutine read_variable_1d(filename, varname, var) if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& " Difficulties reading "//trim(varname)//" from "//trim(filename)) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif call broadcast(var, size(var), blocking=.true.) @@ -655,17 +674,23 @@ end subroutine read_variable_1d !> Read a integer scalar variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_0d_int(filename, varname, var) - 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 - integer, intent(inout) :: var !< The scalar into which to read the data +subroutine read_variable_0d_int(filename, varname, var, ncid_in) + 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 + integer, intent(inout) :: var !< The scalar into which to read the data + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. integer :: varid, ncid, rc character(len=256) :: hdr hdr = "read_variable_0d_int" if (is_root_pe()) then - call open_file_to_read(filename, ncid) + 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)//& @@ -674,7 +699,7 @@ subroutine read_variable_0d_int(filename, varname, var) if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& " Difficulties reading "//trim(varname)//" from "//trim(filename)) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif call broadcast(var, blocking=.true.) @@ -682,17 +707,23 @@ end subroutine read_variable_0d_int !> Read a 1-d integer variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_1d_int(filename, varname, var) +subroutine read_variable_1d_int(filename, varname, var, ncid_in) 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 integer, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. integer :: varid, ncid, rc character(len=256) :: hdr hdr = "read_variable_1d_int" if (is_root_pe()) then - call open_file_to_read(filename, ncid) + 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)//& @@ -701,14 +732,14 @@ subroutine read_variable_1d_int(filename, varname, var) if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& " Difficulties reading "//trim(varname)//" from "//trim(filename)) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif call broadcast(var, size(var), blocking=.true.) end subroutine read_variable_1d_int !> Read a character-string global or variable attribute -subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read) +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 character(len=*), intent(in) :: attname !< Name of the attribute to read character(:), allocatable, intent(out) :: att_val !< The value of the attribute @@ -718,6 +749,8 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this !! routine actually do the read, otherwise only !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. logical :: do_read, do_broadcast integer :: rc, ncid, varid, att_type, att_len, info(2) @@ -729,8 +762,14 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - call open_file_to_read(filename, ncid, success=found) - if (present(found)) then ; if (.not.found) do_read = .false. ; endif + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif if (do_read) then rc = NF90_ENOTATT ; att_len = 0 @@ -759,7 +798,7 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re endif if (present(found)) found = (rc == NF90_NOERR) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif if (do_broadcast) then @@ -786,7 +825,7 @@ end subroutine read_attribute_str !> Read a 32-bit integer global or variable attribute -subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_read) +subroutine read_attribute_int32(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 integer(kind=int32), intent(out) :: att_val !< The value of the attribute @@ -796,6 +835,8 @@ subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_ logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this !! routine actually do the read, otherwise only !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. logical :: do_read, do_broadcast integer :: rc, ncid, varid, is_found @@ -806,8 +847,14 @@ subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_ do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - call open_file_to_read(filename, ncid, success=found) - if (present(found)) then ; if (.not.found) do_read = .false. ; endif + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif if (do_read) then rc = NF90_ENOTATT @@ -827,7 +874,7 @@ subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_ endif if (present(found)) found = (rc == NF90_NOERR) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif if (do_broadcast) then @@ -843,7 +890,7 @@ end subroutine read_attribute_int32 !> Read a 64-bit integer global or variable attribute -subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_read) +subroutine read_attribute_int64(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 integer(kind=int64), intent(out) :: att_val !< The value of the attribute @@ -853,6 +900,8 @@ subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_ logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this !! routine actually do the read, otherwise only !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. logical :: do_read, do_broadcast integer :: rc, ncid, varid, is_found @@ -863,8 +912,14 @@ subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_ do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - call open_file_to_read(filename, ncid, success=found) - if (present(found)) then ; if (.not.found) do_read = .false. ; endif + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif if (do_read) then rc = NF90_ENOTATT @@ -899,7 +954,7 @@ subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_ end subroutine read_attribute_int64 !> Read a real global or variable attribute -subroutine read_attribute_real(filename, attname, att_val, varname, found, all_read) +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 @@ -909,6 +964,8 @@ subroutine read_attribute_real(filename, attname, att_val, varname, found, all_r logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this !! routine actually do the read, otherwise only !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. logical :: do_read, do_broadcast integer :: rc, ncid, varid, is_found @@ -919,8 +976,14 @@ subroutine read_attribute_real(filename, attname, att_val, varname, found, all_r do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read - call open_file_to_read(filename, ncid, success=found) - if (present(found)) then ; if (.not.found) do_read = .false. ; endif + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif if (do_read) then rc = NF90_ENOTATT @@ -940,7 +1003,7 @@ subroutine read_attribute_real(filename, attname, att_val, varname, found, all_r endif if (present(found)) found = (rc == NF90_NOERR) - rc = NF90_close(ncid) + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) endif if (do_broadcast) then @@ -972,6 +1035,22 @@ subroutine open_file_to_read(filename, ncid, success) end subroutine open_file_to_read +!> Close a netcdf file that had been opened for reading, with error handling +subroutine close_file_to_read(ncid, filename) + integer, intent(inout) :: ncid !< The netcdf handle for the file to close + character(len=*), optional, intent(in) :: filename !< path and name of the file to close + integer :: rc + if (ncid >= 0) then + rc = NF90_close(ncid) + if (present(filename) .and. (rc /= NF90_NOERR)) then + call MOM_error(WARNING, "Difficulties closing "//trim(filename)//": "//trim(NF90_STRERROR(rc))) + elseif (rc /= NF90_NOERR) then + call MOM_error(WARNING, "Difficulties closing file: "//trim(NF90_STRERROR(rc))) + endif + endif + ncid = -1 +end subroutine close_file_to_read + !> get_varid finds the netcdf handle for the potentially case-insensitive variable name in a file subroutine get_varid(varname, ncid, filename, varid, match_case, found) character(len=*), intent(in) :: varname !< The name of the variable that is being sought @@ -1362,7 +1441,7 @@ subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value) end subroutine MOM_write_field_0d !> Given filename and fieldname, this subroutine returns the size of the field in the file -subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims) +subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims, ncid_in) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension @@ -1373,12 +1452,14 @@ subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims) !! names with an appended tile number. If !! ndims is present, the default changes to true. integer, optional, intent(out) :: ndims !< The number of dimensions to the variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. if (present(ndims)) then if (present(no_domain)) then ; if (.not.no_domain) call MOM_error(FATAL, & "field_size does not support the ndims argument when no_domain is present and false.") endif - call get_var_sizes(filename, fieldname, ndims, sizes, match_case=.false.) + call get_var_sizes(filename, fieldname, ndims, sizes, match_case=.false., ncid_in=ncid_in) if (present(field_found)) field_found = (ndims >= 0) if ((ndims < 0) .and. .not.present(field_found)) then call MOM_error(FATAL, "Variable "//trim(fieldname)//" not found in "//trim(filename) ) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index ccf9436e14..24c09a881c 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -13,6 +13,7 @@ module MOM_shared_initialization use MOM_file_parser, only : get_param, log_param, param_file_type, log_version use MOM_io, only : close_file, create_file, fieldtype, file_exists, field_size, stdout use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, SINGLE_FILE, MULTIPLE +use MOM_io, only : open_file_to_read, close_file_to_read use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -193,7 +194,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) integer, dimension(:), allocatable :: ig, jg ! The global indicies of the points to modify character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. - integer :: i, j, n, n_edits, i_file, j_file, ndims, sizes(8) + integer :: i, j, n, ncid, n_edits, i_file, j_file, ndims, sizes(8) logical :: found call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -209,19 +210,24 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) if (len_trim(topo_edits_file)==0) return topo_edits_file = trim(inputdir)//trim(topo_edits_file) - if (.not.file_exists(topo_edits_file, G%Domain)) & - call MOM_error(FATAL, trim(mdl)//': Unable to find file '//trim(topo_edits_file)) + if (is_root_PE()) then + if (.not.file_exists(topo_edits_file, G%Domain)) & + call MOM_error(FATAL, trim(mdl)//': Unable to find file '//trim(topo_edits_file)) + call open_file_to_read(topo_edits_file, ncid) + else + ncid = -1 + endif ! Read and check the values of ni and nj in the file for consistency with this configuration. - call read_variable(topo_edits_file, 'ni', i_file) - call read_variable(topo_edits_file, 'nj', j_file) + call read_variable(topo_edits_file, 'ni', i_file, ncid_in=ncid) + call read_variable(topo_edits_file, 'nj', j_file, ncid_in=ncid) if (i_file /= G%ieg) call MOM_error(FATAL, trim(mdl)//': Incompatible i-dimension of grid in '//& trim(topo_edits_file)) if (j_file /= G%jeg) call MOM_error(FATAL, trim(mdl)//': Incompatible j-dimension of grid in '//& trim(topo_edits_file)) ! Get nEdits - call field_size(topo_edits_file, 'zEdit', sizes, ndims=ndims) + call field_size(topo_edits_file, 'zEdit', sizes, ndims=ndims, ncid_in=ncid) if (ndims /= 1) call MOM_error(FATAL, "The variable zEdit has an "//& "unexpected number of dimensions in "//trim(topo_edits_file) ) n_edits = sizes(1) @@ -230,9 +236,10 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) allocate(new_depth(n_edits)) ! Read iEdit, jEdit and zEdit - call read_variable(topo_edits_file, 'iEdit', ig) - call read_variable(topo_edits_file, 'jEdit', jg) - call read_variable(topo_edits_file, 'zEdit', new_depth) + call read_variable(topo_edits_file, 'iEdit', ig, ncid_in=ncid) + call read_variable(topo_edits_file, 'jEdit', jg, ncid_in=ncid) + call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid) + 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 diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 17d72b7d99..ad0a997cc4 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -7,6 +7,7 @@ module MOM_tracer_Z_init ! 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 use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -407,16 +408,22 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) - call get_var_sizes(filename, tr_name, ndim, sizes, dim_names=dim_names) + if (is_root_PE()) then + call open_file_to_read(filename, ncid) + else + ncid = -1 + endif + + call get_var_sizes(filename, tr_name, ndim, sizes, dim_names=dim_names, ncid_in=ncid) if ((ndim < 3) .or. (ndim > 4)) & call MOM_ERROR(FATAL, mdl//" "//trim(tr_msg)//" has too many or too few dimensions.") nz_out = sizes(3) 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) + call read_attribute(filename, "missing_value", missing, varname=tr_name, found=use_missing, ncid_in=ncid) 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) + call read_attribute(filename, "edges", edge_name, varname=dim_names(3), found=has_edges, ncid_in=ncid) nz_edge = sizes(3) ; if (has_edges) nz_edge = sizes(3)+1 allocate(z_edges(nz_edge)) ; z_edges(:) = 0.0 @@ -425,10 +432,11 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & ! Read the right variable. if (has_edges) then - call read_variable(filename, edge_name, z_edges) + call read_variable(filename, edge_name, z_edges, ncid) else - call read_variable(filename, dim_names(3), z_edges) + call read_variable(filename, dim_names(3), z_edges, ncid) endif + call close_file_to_read(ncid, filename) if (allocated(edge_name)) deallocate(edge_name) ! z_edges should be montonically decreasing with our sign convention. From 26be13e4a80bc96f236032169ca8e3edceaa7f80 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 3 Feb 2021 18:40:57 -0500 Subject: [PATCH 192/212] +Added MOM_data_override modules Added two new files, MOM_data_override.F90 and MOM_data_override_infra.F90, to wrap the calls to the FMS data_override module, and to add MOM-specific variants of these calls, including the ability to rescale quantities that are modified by data_override into the right units or to use the right sign convention. All answers are bitwise identical, but there are new interfaces. --- src/framework/MOM_data_override.F90 | 24 +++++ src/framework/MOM_data_override_infra.F90 | 105 ++++++++++++++++++++++ 2 files changed, 129 insertions(+) create mode 100644 src/framework/MOM_data_override.F90 create mode 100644 src/framework/MOM_data_override_infra.F90 diff --git a/src/framework/MOM_data_override.F90 b/src/framework/MOM_data_override.F90 new file mode 100644 index 0000000000..39841913e1 --- /dev/null +++ b/src/framework/MOM_data_override.F90 @@ -0,0 +1,24 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_data_override_infra, only : data_override_init => impose_data_init +use MOM_data_override_infra, only : data_override => impose_data +use MOM_data_override_infra, only : data_override_unset_domains => impose_data_unset_domains + +implicit none ; private + +!> Public functions: +!> mom_data_override_infra:impose_data_init +public :: data_override_init +!> mom_data_override_infra:impose_data +public :: data_override +!> mom_data_override_infra:impose_data_unset_domains +public :: data_override_unset_domains + +end module MOM_data_override + +!> \namespace MOM_data_override +!! +!! APIs are defined and implemented in MOM_data_override_infra diff --git a/src/framework/MOM_data_override_infra.F90 b/src/framework/MOM_data_override_infra.F90 new file mode 100644 index 0000000000..1484f0c128 --- /dev/null +++ b/src/framework/MOM_data_override_infra.F90 @@ -0,0 +1,105 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_time_manager, only : time_type +use data_override_mod, only : data_override_init +use data_override_mod, only : data_override +use data_override_mod, only : data_override_unset_domains + +implicit none ; private + +public :: impose_data_init, impose_data, impose_data_unset_domains + +!> Potentially override the values of a field in the model with values from a dataset. +interface impose_data + module procedure data_override_MD, data_override_2d +end interface + +contains + +!> Initialize the data override capability and set the domains for the ocean and ice components. +!> There should be a call to impose_data_init before impose_data is called. +subroutine impose_data_init(MOM_domain_in, Ocean_domain_in, Ice_domain_in) + type (MOM_domain_type), intent(in), optional :: MOM_domain_in + type (domain2d), intent(in), optional :: Ocean_domain_in + type (domain2d), intent(in), optional :: Ice_domain_in + + if (present(MOM_domain_in)) then + call data_override_init(Ocean_domain_in=MOM_domain_in%mpp_domain, Ice_domain_in=Ice_domain_in) + else + call data_override_init(Ocean_domain_in=Ocean_domain_in, Ice_domain_in=Ice_domain_in) + endif +end subroutine impose_data_init + + +!> Potentially override a 2-d field on a MOM6 domain with values from a dataset. +subroutine data_override_MD(domain, fieldname, data_2D, time, scale, override, is_ice) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call. + type(time_type), intent(in) :: time !< The model time, and the time for the data + real, optional, intent(in) :: scale !< A scaling factor that an overridden field is + !! multiplied by before it is returned. However, + !! if there is no override, there is no rescaling. + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + logical, optional, intent(in) :: is_ice !< If present and true, use the ice domain. + + logical :: overridden, is_ocean + integer :: i, j, is, ie, js, je + + overridden = .false. + is_ocean = .true. ; if (present(is_ice)) is_ocean = .not.is_ice + if (is_ocean) then + call data_override('OCN', fieldname, data_2D, time, override=overridden) + else + call data_override('ICE', fieldname, data_2D, time, override=overridden) + endif + + if (overridden .and. present(scale)) then ; if (scale /= 1.0) then + ! Rescale data in the computational domain if the data override has occurred. + call get_simple_array_i_ind(domain, size(data_2D,1), is, ie) + call get_simple_array_j_ind(domain, size(data_2D,2), js, je) + do j=js,je ; do i=is,ie + data_2D(i,j) = scale*data_2D(i,j) + enddo ; enddo + endif ; endif + + if (present(override)) override = overridden + +end subroutine data_override_MD + + +!> Potentially override a 2-d field with values from a dataset. +subroutine data_override_2d(gridname, fieldname, data_2D, time, override) + character(len=3), intent(in) :: gridname !< String identifying the model component, in MOM6 + !! and SIS this may be either 'OCN' or 'ICE' + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call + type(time_type), intent(in) :: time !< The model time, and the time for the data + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + + call data_override(gridname, fieldname, data_2D, time, override) + +end subroutine data_override_2d + +!> Unset domains that had previously been set for use by data_override. +subroutine impose_data_unset_domains(unset_Ocean, unset_Ice, must_be_set) + logical, intent(in), optional :: unset_Ocean !< If present and true, unset the ocean domain for overrides + logical, intent(in), optional :: unset_Ice !< If present and true, unset the sea-ice domain for overrides + logical, intent(in), optional :: must_be_set !< If present and true, it is a fatal error to unset + !! a domain that is not set. + + call data_override_unset_domains(unset_Ocean=unset_Ocean, unset_Ice=unset_Ice, & + must_be_set=must_be_set) +end subroutine impose_data_unset_domains + +end module MOM_data_override_infra + +!> \namespace MOM_data_override_infra +!! +!! The routines here wrap routines from the FMS module data_override_mod, which potentially replace +!! model values with values read from a data file. From 0b3d2b8942b0ef0e6a8e613310ff6e499ad57943 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 3 Feb 2021 18:41:35 -0500 Subject: [PATCH 193/212] +Use new MOM_data_override interfaces Use the new MOM_data_override interfaces in the MOM6/config_src/solo_driver, MOM6/config_src/coupled_driver, and MOM6/src code, instead of directly accessing the mpp data_override_mod routines. As a part of these, the dimensional rescaling of variables is now done in many places via a scale argument to data_override. The changes in the solo_driver code are more extensive because they were using arguments that do not seem to make sense, and because one of the expressions had omitted dimensionally rescaling factors, although this expression does not appear to have been used in any existing tests. In addition, the get_param calls for BUOY_CONFIG and WIND_CONFIG had not been describing all of the available options, including data_override; this has now been fixed. A number of spelling errors in the same file were also corrected. All answers are bitwise identical, but there are changes to some entries in some MOM_parameter_doc files. --- .../MOM_surface_forcing_gfdl.F90 | 32 ++- .../solo_driver/MOM_surface_forcing.F90 | 204 +++++++----------- src/tracer/MOM_offline_aux.F90 | 14 +- src/user/MOM_wave_interface.F90 | 4 +- 4 files changed, 95 insertions(+), 159 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index dd84f1692c..bb89c4e85e 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -12,6 +12,7 @@ module MOM_surface_forcing_gfdl use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All @@ -36,8 +37,6 @@ module MOM_surface_forcing_gfdl use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS -use data_override_mod, only : data_override_init, data_override - implicit none ; private #include @@ -1118,28 +1117,27 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec - overrode_h = .false. - call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + call data_override(G%Domain, 'hflx_adj', temp_at_h, Time, override=overrode_h, & + scale=US%W_m2_to_QRZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) - overrode_h = .false. - call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + call data_override(G%Domain, 'sflx_adj', temp_at_h, Time, override=overrode_h, & + scale=US%kg_m2s_to_RZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & - US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j) * G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) - overrode_h = .false. - call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + call data_override(G%Domain, 'prcme_adj', temp_at_h, Time, override=overrode_h, & + scale=US%kg_m2s_to_RZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) end subroutine apply_flux_adjustments @@ -1171,8 +1169,8 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) 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('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) - call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) + call data_override(G%Domain, 'taux_adj', tempx_at_h, Time, override=overrode_x, scale=Pa_conversion) + call data_override(G%Domain, 'tauy_adj', tempy_at_h, Time, override=overrode_y, scale=Pa_conversion) if (overrode_x .or. overrode_y) then if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& @@ -1187,8 +1185,8 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = Pa_conversion * tempx_at_h(i,j) - merid_tau = Pa_conversion * tempy_at_h(i,j) + zonal_tau = tempx_at_h(i,j) + merid_tau = tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo @@ -1551,7 +1549,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "above land points (i.e. G%mask2dT = 0).", default=.false., & debuggingParam=.true.) - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call data_override_init(G%Domain) if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 6ace2e05c2..85c363b897 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1,5 +1,5 @@ !> Functions that calculate the surface wind stresses and fluxes of buoyancy -!! or temperature/salinity andfresh water, in ocean-only (solo) mode. +!! or temperature/salinity and fresh water, in ocean-only (solo) mode. !! !! These functions are called every time step, even if the wind stresses !! or buoyancy fluxes are constant in time - in that case these routines @@ -12,6 +12,7 @@ module MOM_surface_forcing use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All @@ -54,7 +55,6 @@ module MOM_surface_forcing use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing -use data_override_mod, only : data_override_init, data_override implicit none ; private @@ -151,7 +151,7 @@ module MOM_surface_forcing character(len=200) :: runoff_file = '' !< The file from which the runoff is read character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read - character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read + character(len=200) :: shortwaveup_file = '' !< The file from which the upward shortwave heat flux is read character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface !! temperature to restore toward @@ -161,7 +161,7 @@ module MOM_surface_forcing character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file character(len=80) :: ustar_var = '' !< ustar variable name in the input file - character(len=80) :: LW_var = '' !< lonngwave heat flux variable name in the input file + character(len=80) :: LW_var = '' !< longwave heat flux variable name in the input file character(len=80) :: SW_var = '' !< shortwave heat flux variable name in the input file character(len=80) :: latent_var = '' !< latent heat flux variable name in the input file character(len=80) :: sens_var = '' !< sensible heat flux variable name in the input file @@ -170,7 +170,7 @@ module MOM_surface_forcing character(len=80) :: snow_var = '' !< snowfall variable name in the input file character(len=80) :: lrunoff_var = '' !< liquid runoff variable name in the input file character(len=80) :: frunoff_var = '' !< frozen runoff variable name in the input file - character(len=80) :: SST_restore_var = '' !< target sea surface temeperature variable name in the input file + character(len=80) :: SST_restore_var = '' !< target sea surface temperature variable name in the input file character(len=80) :: SSS_restore_var = '' !< target sea surface salinity variable name in the input file ! These variables give the number of time levels in the various forcing files. @@ -228,7 +228,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied 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 !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: dt ! length of time over which fluxes applied [s] @@ -243,7 +243,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US dt = time_type_to_real(day_interval) if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. + ! Allocate memory for the mechanical and thermodynamic forcing fields. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) @@ -376,7 +376,7 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] @@ -421,7 +421,7 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: PI @@ -455,7 +455,7 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: PI @@ -488,7 +488,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: PI, y, I_rho @@ -541,7 +541,7 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< Time used for determining the fluxes. type(ocean_grid_type), intent(inout) :: G !< Grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -606,7 +606,7 @@ subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< Time used for determining the fluxes. type(ocean_grid_type), intent(inout) :: G !< Grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, kseg @@ -671,16 +671,16 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes 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 !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! 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 and psuedo-meridional + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and pseudo-meridional real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [R L Z T-1 ~> Pa]. real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress ! units [R Z L T-2 Pa-1 ~> 1] integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and montly cycles. + integer :: time_lev_monthly ! daily and monthly cycles. integer :: time_lev ! The time level that is used for a field. integer :: days, seconds integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -787,13 +787,13 @@ 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 + 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 ) enddo ; enddo else - do j=js, je ; do i=is, ie + 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)) @@ -826,68 +826,58 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes 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 !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - real :: temp_ustar(SZI_(G),SZJ_(G)) ! ustar [m s-1] (not rescaled). + real :: 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)) ! Psuedo-meridional wind stresses at h-points [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] - integer :: i, j, is_in, ie_in, js_in, je_in - logical :: read_uStar + 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.) - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif - is_in = G%isc - G%isd + 1 ; ie_in = G%iec - G%isd + 1 - js_in = G%jsc - G%jsd + 1 ; je_in = G%jec - G%jsd + 1 Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call data_override('OCN', 'taux', temp_x, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - call data_override('OCN', 'tauy', temp_y, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + ! 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_conversion) + call data_override(G%Domain, 'tauy', temp_y, day, scale=Pa_conversion) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - ! Ignore CS%wind_scale when using data_override ????? do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB - forces%taux(I,j) = Pa_conversion * 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + forces%taux(I,j) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo do J=G%jsc-1,G%JecB ; do i=G%isc,G%iec - forces%tauy(i,J) = Pa_conversion * 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + forces%tauy(i,J) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo - read_Ustar = (len_trim(CS%ustar_var) > 0) ! Need better control higher up ???? - if (read_Ustar) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; temp_ustar(i,j) = US%Z_to_m*US%s_to_T*forces%ustar(i,j) ; enddo ; enddo - call data_override('OCN', 'ustar', temp_ustar, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; forces%ustar(i,j) = US%m_to_Z*US%T_to_s*temp_ustar(i,j) ; enddo ; enddo + if (CS%read_gust_2d) then + call data_override(G%Domain, 'gust', CS%gust, day, scale=Pa_conversion) + 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) + enddo ; enddo else - if (CS%read_gust_2d) then - call data_override('OCN', 'gust', CS%gust, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt((Pa_conversion * sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) * US%L_to_Z / CS%Rho0) - enddo ; enddo - else - do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt(US%L_to_Z * (Pa_conversion*sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + CS%gust_const/CS%Rho0 )) - enddo ; enddo - endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec + 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. + call data_override(G%Domain, 'ustar', forces%ustar, day, scale=US%m_to_Z*US%T_to_s) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) -! call pass_var(forces%ustar, G%Domain, To_All) Not needed ????? call callTree_leave("wind_forcing_by_data_override") end subroutine wind_forcing_by_data_override -!> Specifies zero surface bouyancy fluxes from input files. +!> Specifies zero surface buoyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. @@ -897,7 +887,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) !! the fluxes apply [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 !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -1165,7 +1155,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call callTree_leave("buoyancy_forcing_from_files") end subroutine buoyancy_forcing_from_files -!> Specifies zero surface bouyancy fluxes from data over-ride. +!> Specifies zero surface buoyancy fluxes from data over-ride. subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. @@ -1175,7 +1165,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US !! the fluxes apply [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 !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -1190,14 +1180,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - - integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and montly cycles. - integer :: itime_lev ! The time level that is used for a field. - - integer :: days, seconds integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - integer :: is_in, ie_in, js_in, je_in call callTree_enter("buoyancy_forcing_from_data_override, MOM_surface_forcing.F90") @@ -1208,75 +1191,32 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p if (.not.CS%dataOverrideIsInitialized) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif - is_in = G%isc - G%isd + 1 - ie_in = G%iec - G%isd + 1 - js_in = G%jsc - G%jsd + 1 - je_in = G%jec - G%jsd + 1 + call data_override(G%Domain, 'lw', fluxes%lw, day, scale=US%W_m2_to_QRZ_T) + call data_override(G%Domain, 'sw', fluxes%sw, day, scale=US%W_m2_to_QRZ_T) - call data_override('OCN', 'lw', fluxes%lw(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%W_m2_to_QRZ_T - if (US%QRZ_T_to_W_m2 /= 1.0) then ; do j=js,je ; do i=is,ie - fluxes%lw(i,j) = fluxes%lw(i,j) * US%W_m2_to_QRZ_T - enddo ; enddo ; endif - call data_override('OCN', 'evap', fluxes%evap(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + ! The normal MOM6 sign conventions are that fluxes%evap and fluxes%sens are positive into the + ! ocean but evap and sens are normally positive quantities in the files. + call data_override(G%Domain, 'evap', fluxes%evap, day, scale=-US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'sens', fluxes%sens, day, scale=-US%W_m2_to_QRZ_T) - ! note the sign convention do j=js,je ; do i=is,ie - ! The normal convention is that fluxes%evap positive into the ocean - ! but evap is normally a positive quantity in the files - ! This conversion is dangerous because it is not clear whether the data files have been read! - fluxes%evap(i,j) = -kg_m2_s_conversion*fluxes%evap(i,j) fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo - call data_override('OCN', 'sens', fluxes%sens(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - ! note the sign convention - do j=js,je ; do i=is,ie - fluxes%sens(i,j) = -US%W_m2_to_QRZ_T * fluxes%sens(i,j) ! Normal convention is positive into the ocean - ! but sensible is normally a positive quantity in the files - enddo ; enddo - - call data_override('OCN', 'sw', fluxes%sw(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%W_m2_to_QRZ_T - if (US%QRZ_T_to_W_m2 /= 1.0) then ; do j=js,je ; do i=is,ie - fluxes%sw(i,j) = fluxes%sw(i,j) * US%W_m2_to_QRZ_T - enddo ; enddo ; endif - - call data_override('OCN', 'snow', fluxes%fprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion - - call data_override('OCN', 'rain', fluxes%lprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion - - call data_override('OCN', 'runoff', fluxes%lrunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion - - call data_override('OCN', 'calving', fluxes%frunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion - - if (kg_m2_s_conversion /= 1.0) then ; do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) * kg_m2_s_conversion - fluxes%fprec(i,j) = fluxes%fprec(i,j) * kg_m2_s_conversion - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * kg_m2_s_conversion - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * kg_m2_s_conversion - enddo ; enddo ; endif + call data_override(G%Domain, 'snow', fluxes%fprec, day, scale=kg_m2_s_conversion) + call data_override(G%Domain, 'rain', fluxes%lprec, day, scale=kg_m2_s_conversion) + call data_override(G%Domain, 'runoff', fluxes%lrunoff, day, scale=kg_m2_s_conversion) + call data_override(G%Domain, 'calving', fluxes%frunoff, day, scale=kg_m2_s_conversion) ! Read the SST and SSS fields for damping. if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then - call data_override('OCN', 'SST_restore', CS%T_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'SSS_restore', CS%S_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - + call data_override(G%Domain, 'SST_restore', CS%T_restore, day) + call data_override(G%Domain, 'SSS_restore', CS%S_restore, day) endif ! restoring boundary fluxes @@ -1334,7 +1274,6 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo - !#CTRL# if (associated(CS%ctrl_forcing_CSp)) then !#CTRL# do j=js,je ; do i=is,ie !#CTRL# SST_anom(i,j) = sfc_state%SST(i,j) - CS%T_Restore(i,j) @@ -1348,7 +1287,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US call callTree_leave("buoyancy_forcing_from_data_override") end subroutine buoyancy_forcing_from_data_override -!> This subroutine specifies zero surface bouyancy fluxes +!> This subroutine specifies zero surface buoyancy fluxes subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. @@ -1357,7 +1296,7 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) real, intent(in) :: dt !< The amount of time over which !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, is, ie, js, je @@ -1401,7 +1340,7 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, US, CS) !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, is, ie, js, je @@ -1444,7 +1383,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real :: y, T_restore, S_restore @@ -1518,7 +1457,7 @@ end subroutine buoyancy_forcing_linear !> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(time_type), intent(in) :: Time !< model time at this call; needed for mpp_write calls @@ -1526,7 +1465,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & logical, optional, intent(in) :: time_stamped !< If true, the restart file names !! include a unique time stamp; the default is false. character(len=*), optional, intent(in) :: filename_suffix !< optional suffix (e.g., a time-stamp) - !! to append to the restart fname + !! to append to the restart file name if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return @@ -1542,7 +1481,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< Forcing for tracers? @@ -1593,9 +1532,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "initialization of the model.", default=.true.) 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), (zero), "//& - "(linear), (USER), (BFB) and (NONE).", default="zero") + "The character string that indicates how buoyancy forcing is specified. Valid "//& + "options include (file), (data_override), (zero), (const), (linear), (MESO), "//& + "(SCM_CVmix_tests), (BFB), (dumbbell), (USER) and (NONE).", default="zero") if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "ARCHAIC_OMIP_FORCING_FILE", CS%archaic_OMIP_file, & "If true, use the forcing variable decomposition from "//& @@ -1735,9 +1674,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units='W/m2', scale=US%W_m2_to_QRZ_T, fail_if_missing=.true.) endif 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), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", default="zero") + "The character string that indicates how wind forcing is specified. Valid "//& + "options include (file), (data_override), (2gyre), (1gyre), (gyres), (zero), "//& + "(const), (Neverworld), (scurves), (ideal_hurr), (SCM_ideal_hurr), "//& + "(SCM_CVmix_tests) and (USER).", default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& @@ -1964,7 +1904,7 @@ end subroutine surface_forcing_init !> Deallocate memory associated with the surface forcing module subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(forcing), optional, intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields ! Arguments: CS - A pointer to the control structure returned by a previous diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 6900f76fa5..59e63a5ddd 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,22 +4,20 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use data_override_mod, only : data_override_init, data_override -use MOM_time_manager, only : time_type, operator(-) 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_time_manager, only : time_type, operator(-) +use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar -use MOM_variables, only : vertvisc_type -use MOM_forcing_type, only : forcing -use MOM_opacity, only : optics_type -use MOM_diag_mediator, only : post_data -use MOM_forcing_type, only : forcing implicit none ; private diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 4531c63b99..a8e3e207a6 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -3,6 +3,7 @@ module MOM_wave_interface ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID @@ -16,7 +17,6 @@ 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 data_override_mod, only : data_override_init, data_override use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var use netcdf, only : NF90_inquire_dimension, NF90_close, NF90_NOWRITE, NF90_NOERR @@ -794,7 +794,7 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) integer :: rcode_fr, rcode_wn, ncid, varid_fr, varid_wn, id, ndims if (.not.dataOverrideIsInitialized) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call data_override_init(G%Domain) dataOverrideIsInitialized = .true. ! Read in number of wavenumber bands in file to set number to be read in From 7f0f4995156322d05068e9e77b5f0f01bd2e90e2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 3 Feb 2021 18:44:07 -0500 Subject: [PATCH 194/212] +Minor cleanup of framework files Moved MOM_spatial_means.F90 from src/framework to src/diagnostics, and eliminated MOM_transform_FMS.F90, which is no longer used. Also correct an instance of "the the " in one MOM_parameter_doc description, which changes some MOM_parameter_doc.layout files. All answers are bitwise identical. --- .../MOM_spatial_means.F90 | 0 src/framework/MOM_domains.F90 | 5 +- src/framework/MOM_transform_FMS.F90 | 131 ------------------ 3 files changed, 1 insertion(+), 135 deletions(-) rename src/{framework => diagnostics}/MOM_spatial_means.F90 (100%) delete mode 100644 src/framework/MOM_transform_FMS.F90 diff --git a/src/framework/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 similarity index 100% rename from src/framework/MOM_spatial_means.F90 rename to src/diagnostics/MOM_spatial_means.F90 diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index b1b3a3c6a8..88415c6782 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -196,11 +196,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & "If true, non-blocking halo updates may be used.", & default=.false., layoutParam=.true.) - !### Note the duplicated "the the" in the following description, which should be fixed as a part - ! of a larger commit that also changes other MOM_parameter_doc file messages, but for now - ! reproduces the existing output files. call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & - "If true, optional arguments may be used to specify the the width of the "//& + "If true, optional arguments may be used to specify the width of the "//& "halos that are updated with each call.", & default=.true., layoutParam=.true.) diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 deleted file mode 100644 index a4a3f7c2c4..0000000000 --- a/src/framework/MOM_transform_FMS.F90 +++ /dev/null @@ -1,131 +0,0 @@ -!> Support functions and interfaces to permit transformed model domains to -!! interact with FMS operations registered on the non-transformed domains. - -module MOM_transform_FMS - -use MOM_array_transform, only : allocate_rotated_array, rotate_array -use MOM_error_handler, only : MOM_error, FATAL -use horiz_interp_mod, only : horiz_interp_type -use time_manager_mod, only : time_type -use time_interp_external_mod, only : time_interp_external - -implicit none ; private - -public rotated_time_interp_external - -!> Read a field based on model time, and rotate to the model domain -interface rotated_time_interp_external - module procedure rotated_time_interp_external_0d - module procedure rotated_time_interp_external_2d - module procedure rotated_time_interp_external_3d -end interface rotated_time_interp_external - -contains - -! NOTE: No transformations are applied to the 0d and 1d field implementations, -! but are provided to maintain compatibility with the FMS interfaces. - -!> Read a scalar field based on model time -!! This function is provided to support the full FMS time_interp_external -!! interface. -subroutine rotated_time_interp_external_0d(fms_id, time, data_in, verbose, & - turns) - integer, intent(in) :: fms_id !< FMS field ID - type(time_type), intent(in) :: time !< Model time - real, intent(inout) :: data_in !< field to write data - logical, intent(in), optional :: verbose !< Verbose output - integer, intent(in), optional :: turns !< Number of quarter turns - - if (present(turns)) & - call MOM_error(FATAL, "Rotation not supported for 0d fields.") - - call time_interp_external(fms_id, time, data_in, verbose=verbose) -end subroutine rotated_time_interp_external_0d - -!> Read a 2d field based on model time, and rotate to the model grid -subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & - verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & - turns) - integer, intent(in) :: fms_id - type(time_type), intent(in) :: time - real, dimension(:,:), intent(inout) :: data_in - integer, intent(in), optional :: interp - logical, intent(in), optional :: verbose - type(horiz_interp_type),intent(in), optional :: horz_interp - logical, dimension(:,:), intent(out), optional :: mask_out - integer, intent(in), optional :: is_in, ie_in, js_in, je_in - integer, intent(in), optional :: window_id - integer, intent(in), optional :: turns - - real, allocatable :: data_pre(:,:) - integer :: qturns - - ! TODO: Mask rotation requires logical array rotation support - if (present(mask_out)) & - call MOM_error(FATAL, "Rotation of masked output not yet support") - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - - if (qturns == 0) then - call time_interp_external(fms_id, time, data_in, interp=interp, & - verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & - window_id=window_id) - else - call allocate_rotated_array(data_in, [1,1], -qturns, data_pre) - call time_interp_external(fms_id, time, data_pre, interp=interp, & - verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & - window_id=window_id) - call rotate_array(data_pre, turns, data_in) - deallocate(data_pre) - endif -end subroutine rotated_time_interp_external_2d - - -!> Read a 3d field based on model time, and rotate to the model grid -subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & - verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & - turns) - integer, intent(in) :: fms_id - type(time_type), intent(in) :: time - real, dimension(:,:,:), intent(inout) :: data_in - integer, intent(in), optional :: interp - logical, intent(in), optional :: verbose - type(horiz_interp_type),intent(in), optional :: horz_interp - logical, dimension(:,:,:), intent(out), optional :: mask_out - integer, intent(in), optional :: is_in, ie_in, js_in, je_in - integer, intent(in), optional :: window_id - integer, intent(in), optional :: turns - - real, allocatable :: data_pre(:,:,:) - integer :: qturns - - ! TODO: Mask rotation requires logical array rotation support - if (present(mask_out)) & - call MOM_error(FATAL, "Rotation of masked output not yet support") - - qturns = 0 - if (present(turns)) & - qturns = modulo(turns, 4) - - if (qturns == 0) then - call time_interp_external(fms_id, time, data_in, interp=interp, & - verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & - window_id=window_id) - else - call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre) - call time_interp_external(fms_id, time, data_pre, interp=interp, & - verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & - window_id=window_id) - call rotate_array(data_pre, turns, data_in) - deallocate(data_pre) - endif -end subroutine rotated_time_interp_external_3d - -end module MOM_transform_FMS From 1ae4e16d4f32c29f8aa5caf210799ac089e5ab36 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Thu, 4 Feb 2021 05:06:29 -0500 Subject: [PATCH 195/212] interface for MOM_interp_infra (#1310) This PR provides new explicit interfaces to the horizontal interpolation routines with thin-layer wrappers of the underlying FMS infrastructure routines. It also renames the key routines, from horiz_interp_new to build_horiz_interp_weights and from horiz_interp to run_horiz_interp, to more accurately reflect what these routines do. Successful testing has verified that all answers are bitwise identical, and there are no changes to any output files. --- src/framework/MOM_horizontal_regridding.F90 | 17 +-- src/framework/MOM_interp_infra.F90 | 135 +++++++++++++++++++- src/framework/MOM_interpolate.F90 | 5 +- 3 files changed, 143 insertions(+), 14 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index d63e2d743a..a16fa2c067 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -12,7 +12,7 @@ module MOM_horizontal_regridding use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : time_interp_external, get_external_field_info, horiz_interp_init -use MOM_interpolate, only : horiz_interp_new, horiz_interp, horiz_interp_type +use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type use MOM_io_infra, only : axistype, get_axis_data use MOM_time_manager, only : time_type @@ -526,8 +526,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (.not. is_ongrid) then if (k == 1) then - call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & - interp_method='bilinear', src_modulo=.true.) + call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) endif if (debug) then @@ -539,7 +539,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_ongrid) then tr_out(is:ie,js:je)=tr_in(is:ie,js:je) else - call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), & + missing_value=missing_value, new_missing_handle=.true.) endif mask_out=1.0 @@ -810,8 +811,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then - call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & - interp_method='bilinear', src_modulo=.true.) + call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) endif if (debug) then @@ -820,8 +821,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t tr_out(:,:) = 0.0 - call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & - new_missing_handle=.true.) + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & + new_missing_handle=.true.) mask_out(:,:) = 1.0 do j=js,je ; do i=is,ie diff --git a/src/framework/MOM_interp_infra.F90 b/src/framework/MOM_interp_infra.F90 index d9de006224..c9151b841e 100644 --- a/src/framework/MOM_interp_infra.F90 +++ b/src/framework/MOM_interp_infra.F90 @@ -14,9 +14,10 @@ module MOM_interp_infra implicit none ; private +public :: horiz_interp_type, horiz_interp_init public :: time_interp_extern, init_extern_field, time_interp_external_init public :: get_external_field_info -public :: horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new +public :: run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. interface time_interp_extern @@ -25,8 +26,131 @@ module MOM_interp_infra module procedure time_interp_extern_3d end interface time_interp_extern +!> perform horizontal interpolation of field +interface run_horiz_interp + module procedure horiz_interp_from_weights_field2d + module procedure horiz_interp_from_weights_field3d +end interface + +!> build weights for horizontal interpolation of field +interface build_horiz_interp_weights + module procedure build_horiz_interp_weights_2d_to_2d +end interface build_horiz_interp_weights + contains +!> perform horizontal interpolation of a 2d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation + !! options/weights + real, intent(in), dimension(:,:) :: data_in !< input data + real, intent(out), dimension(:,:) :: data_out !< output data + integer, intent(in), optional :: verbose !< verbosity level + real, intent(in), dimension(:,:), optional :: mask_in !< mask for input data + real, intent(out), dimension(:,:), optional :: mask_out !< mask for output data + real, intent(in), optional :: missing_value !< missing value + integer, intent(in), optional :: missing_permit !< number of allowed points with missing value + !! for interpolation (0-3) + character(len=*), intent(out), optional :: err_msg !< error message + logical, intent(in), optional :: new_missing_handle !< unknown + + call horiz_interp(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle ) + +end subroutine horiz_interp_from_weights_field2d + + +!> perform horizontal interpolation of a 3d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation + !! options/weights + real, intent(in), dimension(:,:,:) :: data_in !< input data + real, intent(out), dimension(:,:,:) :: data_out !< output data + integer, intent(in), optional :: verbose !< verbosity level + real, intent(in), dimension(:,:,:), optional :: mask_in !< mask for input data + real, intent(out), dimension(:,:,:), optional :: mask_out !< mask for output data + real, intent(in), optional :: missing_value !< missing value + integer, intent(in), optional :: missing_permit !< number of allowed points with missing value + !! for interpolation (0-3) + character(len=*), intent(out), optional :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + +end subroutine horiz_interp_from_weights_field3d + + +!> build horizontal interpolation weights from source grid defined by 2d lon/lat to destination grid +!! defined by 2d lon/lat +subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options/weights + real, intent(in), dimension(:,:) :: lon_in !< input longitude 2d + real, intent(in), dimension(:,:) :: lat_in !< input latitude 2d + real, intent(in), dimension(:,:) :: lon_out !< output longitude 2d + real, intent(in), dimension(:,:) :: lat_out !< output latitude 2d + integer, intent(in), optional :: verbose !< verbosity level + character(len=*), intent(in), optional :: interp_method !< interpolation method + integer, intent(in), optional :: num_nbrs !< number of nearest neighbors + real, intent(in), optional :: max_dist !< maximum region of influence + logical, intent(in), optional :: src_modulo !< periodicity of E-W boundary + real, intent(in), dimension(:,:), optional :: mask_in !< mask for input data + real, intent(inout),dimension(:,:), optional :: mask_out !< mask for output data + logical, intent(in), optional :: is_latlon_in !< input grid is regular lat/lon grid + logical, intent(in), optional :: is_latlon_out !< output grid is regular lat/lon grid + + call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + +end subroutine build_horiz_interp_weights_2d_to_2d + + +!> get size of an external field from field index +function get_extern_field_size(index) + + integer :: index !< field index + integer :: get_extern_field_size(4) !< field size + + get_extern_field_size = get_external_field_size(index) + +end function get_extern_field_size + + +!> get axes of an external field from field index +function get_extern_field_axes(index) + + integer :: index !< field index + type(axistype), dimension(4) :: get_extern_field_axes !< field axes + + get_extern_field_axes = get_external_field_axes(index) + +end function get_extern_field_axes + + +!> get missing value of an external field from field index +function get_extern_field_missing(index) + + integer :: index !< field index + real :: get_extern_field_missing !< field missing value + + get_extern_field_missing = get_external_field_missing(index) + +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 @@ -37,15 +161,15 @@ 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_external_field_size(field_id) + size(1:4) = get_extern_field_size(field_id) endif if (present(axes)) then - axes(1:4) = get_external_field_axes(field_id) + axes(1:4) = get_extern_field_axes(field_id) endif if (present(missing)) then - missing = get_external_field_missing(field_id) + missing = get_extern_field_missing(field_id) endif end subroutine get_external_field_info @@ -62,6 +186,7 @@ subroutine time_interp_extern_0d(field_id, time, data_in, 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) @@ -98,6 +223,8 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ 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 ) diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 6a5a4b2cc6..f282d03ff6 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -7,14 +7,15 @@ module MOM_interpolate use MOM_error_handler, only : MOM_error, FATAL use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field use MOM_interp_infra, only : time_interp_external_init, get_external_field_info -use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init, horiz_interp, horiz_interp_new +use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init +use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_io_infra, only : axistype 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, horiz_interp_init, horiz_interp, horiz_interp_new +public :: horiz_interp_type, horiz_interp_init, run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. interface time_interp_external From 1b4f41c837684d56f66e30bb14d8c1c11bec5553 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 4 Feb 2021 07:06:10 -0500 Subject: [PATCH 196/212] NCAR sponge merge (#1308) This PR contains updates provided by NCAR that act on velocities in sponges to provide damping accelerations toward specified velocities in MOM_ALE_sponge. Associated with this change are new runtime parameters to control the use of sponges on tracers and new diagnostics of the tendencies due to the ALE sponges, but these changes only appear in the MOM_parameter_doc or available_diags files if ALE sponges are in active use or if the sponges are initialized from a file, and no changes to these files were found with the standard pipeline testing, perhaps reflecting an important limitation in this testing. As a part of this work, a bug was identified in the case of incoming sponge data residing on the model horizontal grid where the returned mask was not initialized properly. The 2018 answers flags are being used to retain the bug and should be set to False for new experiments. The new velocity sponges are activated by setting SPONGE_UV=True and SPONGE_CONFIG="file". The sponge accelerations use the tracer damping timescale by default but this can be set independently. Significant pre-squash commit descriptions include: * sponge layer changes * add uv-specific iresttime for sponges * fix idamp_u init * fix mask_z init * improve tracer sponge apply * fix velocity sponge apply * Enable sponge tendency diagnostics - sp_tendency_temp and sp_tendency_salt are new diagnostic variables which evaluate the respective tracer tendendies (tr_units/sec). - sp_tendency_u and sp_tendency_v diagnose the accelerations (m/sec) applied from calls to the sponge routine. - No attempt has been made to CMOR-ize these diagnostics. - More work is needed to generalize this code for additional tracers. * merging updates from NCAR for uv sponges * Changes for uv sponges and sponge diagnostics - this PR includes updates from NCAR for uv momentum sponge implementation. - Diagnostics are included for tracer tendencies and accelerations due to sponge terms. - The uv sponge feature is currently not being tested. This will be addressed in a future PR which will add sponge accelerations to tc4. * initialize h_col prior to calling remapping * Toggle bug in horiz_interp_and_extrap_tracer mask for ongrid data - A previous bug in the 3-dimensional mask returned from this routine in the case where the data to be interpolated reside on the model's horizontal grid is retained using the 2018_answers flag. - If 2018_answers is set to True, the mask is not properly initialized and this leads to incorrect vertical reconstructions in the ALE sponge code. - 2018 flags (DEFAULT_2018_ANSWERS or HOR_REGRID_2018_ANSWERS) should be set to False for any cases using sponge restoring for tracers or momentum. * update parameter documentation * Adds uv sponge initialization for non time-varying data Co-authored-by: alperaltuntas Co-authored-by: Robert Hallberg --- src/core/MOM.F90 | 11 +- src/framework/MOM_horizontal_regridding.F90 | 18 +- .../MOM_state_initialization.F90 | 131 +++++- .../vertical/MOM_ALE_sponge.F90 | 430 ++++++++++++------ 4 files changed, 430 insertions(+), 160 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index cd4a3934b6..9b94a96797 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2652,11 +2652,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & param_file, diag, CS%diagnostics_CSp, CS%tv) call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) - if (associated(CS%sponge_CSp)) & - call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) - - if (associated(CS%ALE_sponge_CSp)) & - call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp) if (CS%adiabatic) then call adiabatic_driver_init(Time, G, param_file, diag, CS%diabatic_CSp, & @@ -2667,6 +2662,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%sponge_CSp, CS%ALE_sponge_CSp) endif + if (associated(CS%sponge_CSp)) & + call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) + + if (associated(CS%ALE_sponge_CSp)) & + call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US) + call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & CS%tracer_diff_CSp) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index a16fa2c067..a4a483711a 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -667,6 +667,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t character(len=12) :: dim_name(4) logical :: debug=.false. logical :: spongeDataOngrid + logical :: ans_2018 real :: npoints, varAvg real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid @@ -688,6 +689,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t PI_180 = atan(1.0)/45. + ans_2018 = .true.;if (present(answers_2018)) ans_2018 = answers_2018 + ! Open NetCDF file and if present, extract data and spatial coordinate information ! The convention adopted here requires that the data be written in (i,j,k) ordering. @@ -886,15 +889,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) - do k=1,kd - do j=js,je - do i=is,ie - tr_z(i,j,k) = data_in(i,j,k) - if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. + call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k)=data_in(i,j,k) + if (.not. ans_2018) 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 enddo enddo - enddo endif end subroutine horiz_interp_and_extrap_tracer_fms_id diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f616f09e10..b54d9702a6 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -31,7 +31,8 @@ module MOM_state_initialization use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +use MOM_ALE_sponge, only : ALE_sponge_CS, initialize_ALE_sponge use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type @@ -549,7 +550,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("phillips"); call Phillips_initialize_sponges(G, GV, US, tv, PF, sponge_CSp, h) case ("dense"); call dense_water_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) - case ("file"); call initialize_sponges_file(G, GV, US, use_temperature, tv, PF, & + case ("file"); call initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, PF, & sponge_CSp, ALE_sponge_CSp, Time) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized sponge configuration "//trim(config)) @@ -1718,13 +1719,19 @@ end subroutine initialize_temp_salt_linear !! number of tracers should be restored within each sponge. The !! interface height is always subject to damping, and must always be !! the first registered field. -subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, Layer_CSp, ALE_CSp, Time) +subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, param_file, Layer_CSp, ALE_CSp, 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 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. + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + 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(sponge_CS), pointer :: Layer_CSp !< A pointer that is set to point to the control !! structure for this module (in layered mode). @@ -1741,8 +1748,11 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L 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 real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. + real :: Idamp_u(SZIB_(G),SZJ_(G)) ! The inverse damping rate for velocity fields [T-1 ~> s-1]. + real :: Idamp_v(SZI_(G),SZJB_(G)) ! The inverse damping rate for velocity fields [T-1 ~> s-1]. real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -1750,9 +1760,10 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L integer :: isd, ied, jsd, jed integer, dimension(4) :: siz integer :: nz_data ! The size of the sponge source grid - character(len=40) :: potemp_var, salin_var, Idamp_var, eta_var + logical :: sponge_uv ! Apply sponges in u and v, in addition to tracers. + character(len=40) :: potemp_var, salin_var, u_var, v_var, Idamp_var, Idamp_u_var, Idamp_v_var, eta_var character(len=40) :: mdl = "initialize_sponges_file" - character(len=200) :: damping_file, state_file ! Strings for filenames + 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. logical :: use_ALE ! True if ALE is being used, False if in layered mode @@ -1764,7 +1775,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L 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 - pres(:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + pres(:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 ; Idamp_u(:,:) = 0.0 ; Idamp_v(:,:) = 0.0 call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -1774,18 +1785,43 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L call get_param(param_file, mdl, "SPONGE_STATE_FILE", state_file, & "The name of the file with the state to damp toward.", & default=damping_file) + call get_param(param_file, mdl, "SPONGE_UV_STATE_FILE", state_uv_file, & + "The name of the file with the state to damp UV toward.", & + default=damping_file) call get_param(param_file, mdl, "SPONGE_PTEMP_VAR", potemp_var, & "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="PTEMP") call get_param(param_file, mdl, "SPONGE_SALT_VAR", salin_var, & "The name of the salinity variable in "//& "SPONGE_STATE_FILE.", default="SALT") + call get_param(param_file, mdl, "SPONGE_UV", sponge_uv, & + "Apply sponges in u and v, in addition to tracers.", & + default=.false.) + if (sponge_uv) then + call get_param(param_file, mdl, "SPONGE_U_VAR", u_var, & + "The name of the zonal velocity variable in "//& + "SPONGE_UV_STATE_FILE.", default="UVEL") + call get_param(param_file, mdl, "SPONGE_V_VAR", v_var, & + "The name of the vertical velocity variable in "//& + "SPONGE_UV_STATE_FILE.", default="VVEL") + endif call get_param(param_file, mdl, "SPONGE_ETA_VAR", eta_var, & "The name of the interface height variable in "//& "SPONGE_STATE_FILE.", default="ETA") call get_param(param_file, mdl, "SPONGE_IDAMP_VAR", Idamp_var, & "The name of the inverse damping rate variable in "//& - "SPONGE_DAMPING_FILE.", default="Idamp") + "SPONGE_DAMPING_FILE.", default="IDAMP") + if (sponge_uv) then + call get_param(param_file, mdl, "SPONGE_UV_DAMPING_FILE", uv_damping_file, & + "The name of the file with sponge damping rates for the velocity variables.", & + default=damping_file) + call get_param(param_file, mdl, "SPONGE_IDAMP_U_var", Idamp_u_var, & + "The name of the inverse damping rate variable in "//& + "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) + call get_param(param_file, mdl, "SPONGE_IDAMP_V_var", Idamp_v_var, & + "The name of the inverse damping rate variable in "//& + "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) + endif call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) time_space_interp_sponge = .false. call get_param(param_file, mdl, "NEW_SPONGES", time_space_interp_sponge, & @@ -1802,6 +1838,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L "performs on-the-fly regridding in lat-lon-time.",& "of sponge restoring data.", default=time_space_interp_sponge) + + ! Read in inverse damping rate for tracers filename = trim(inputdir)//trim(damping_file) call log_param(param_file, mdl, "INPUTDIR/SPONGE_DAMPING_FILE", filename) if (.not.file_exists(filename, G%Domain)) & @@ -1812,6 +1850,32 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L call MOM_read_data(filename, Idamp_var, Idamp(:,:), G%Domain, scale=US%T_to_s) + ! Read in inverse damping rate for velocities + if (sponge_uv) then + if (separate_idamp_for_uv()) then + filename = trim(inputdir)//trim(uv_damping_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_UV_DAMPING_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + + call MOM_read_vector(filename, Idamp_u_var,Idamp_v_var,Idamp_u(:,:),Idamp_v(:,:), G%Domain, scale=US%T_to_s) + else + ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") + call pass_var(Idamp,G%Domain) + do j=G%jsc,G%jec + do i=G%iscB,G%iecB + Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) + enddo + enddo + do j=G%jscB,G%jecB + do i=G%isc,G%iec + Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) + enddo + enddo + endif + endif + ! 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. @@ -1869,11 +1933,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L call set_up_sponge_field(tmp, tv%S, G, GV, nz, Layer_CSp) endif +! 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) +! else +! call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) +! endif endif - if (use_ALE) then - if (.not. time_space_interp_sponge) then ! ALE mode + if (use_ALE) then ! ALE mode + if (.not. time_space_interp_sponge) then call field_size(filename,eta_var,siz,no_domain=.true.) if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & call MOM_error(FATAL,"initialize_sponge_file: Array size mismatch for sponge data.") @@ -1890,8 +1961,12 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L 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)) - enddo ; enddo ; enddo - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) + enddo; enddo ; enddo + 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 @@ -1902,20 +1977,50 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, L call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%S, ALE_CSp) deallocate(tmp_tr) endif + if (sponge_uv) then + filename = trim(inputdir)//trim(state_uv_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data)) + allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data)) + call MOM_read_vector(filename, u_var, v_var, tmp_u(:,:,:), tmp_v(:,:,:), G%Domain,scale=US%m_s_to_L_T) + call set_up_ALE_sponge_vel_field(tmp_u, tmp_v, G, GV, u, v, ALE_CSp) + deallocate(tmp_u,tmp_v) + endif else ! Initialize sponges without supplying sponge grid - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) + if (sponge_uv) then + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, Idamp_u, Idamp_v) + else + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) + endif ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) endif + if (sponge_uv) then + filename = trim(inputdir)//trim(state_uv_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + call set_up_ALE_sponge_vel_field(filename, u_var, filename, v_var, Time, G, GV, US, ALE_CSp, u, v) + endif endif + endif + if (sponge_uv .and. .not. use_ALE) call MOM_error(FATAL,'initialize_sponges_file: '// & + 'UV damping to target values only available in ALE mode') - endif + contains + ! returns true if a separate idamp is provided for u and/or v + logical function separate_idamp_for_uv() + separate_idamp_for_uv = (lowercase(damping_file)/=lowercase(uv_damping_file) .or. & + lowercase(Idamp_var)/=lowercase(Idamp_u_var) .or. lowercase(Idamp_var)/=lowercase(Idamp_v_var)) + end function separate_idamp_for_uv end subroutine initialize_sponges_file diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 548b1d04f4..aa224dba41 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -16,6 +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_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 +28,9 @@ module MOM_ALE_sponge use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use mpp_io_mod, only : mpp_get_axis_length +use mpp_io_mod, only : axistype + implicit none ; private #include @@ -139,16 +143,29 @@ 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(2) :: id_sp_tendency !< Diagnostic ids for temperature and salinity + !! tendency 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 + !! Rayleigh damping end type ALE_sponge_CS contains !> This subroutine determines the number of points which are within sponges in this computational !! 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) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. +!! points are included in the sponges. It also stores the target interface heights. This +subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & + 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 integer, intent(in) :: nz_data !< The total number of sponge input layers. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: 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 @@ -157,6 +174,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, !! structure for this module (in/out). real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: 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 + !! 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]. ! This include declares and sets the variable "version". @@ -212,6 +233,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "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) + 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 @@ -262,10 +288,17 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 + CS%num_col_u = 0 ; + if (present(Iresttime_u_in)) then + Iresttime_u(:,:) = Iresttime_u_in(:,:) + else + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + enddo ; enddo + endif do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) CS%num_col_u = CS%num_col_u + 1 + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -299,10 +332,17 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) CS%num_col_v = CS%num_col_v + 1 + CS%num_col_v = 0 ; + if (present(Iresttime_v_in)) then + Iresttime_v(:,:) = Iresttime_v_in(:,:) + else + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + enddo ; enddo + endif + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = CS%num_col_v + 1 enddo ; enddo if (CS%num_col_v > 0) then @@ -390,20 +430,25 @@ end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are to be restoref in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. -subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. +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. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + 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. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). + real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring time + !! for u [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring time + !! for v [T-1 ~> s-1]. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. logical :: use_sponge - real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] + 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] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers @@ -444,10 +489,22 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", CS%hor_regrid_answers_2018, & + "If true, use the order of arithmetic for horizonal 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) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & default=.false.) + 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 CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec @@ -485,10 +542,18 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) if (CS%sponge_uv) then allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)) ; Iresttime_u(:,:) = 0.0 allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 + + call pass_var(Iresttime,G%Domain) ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + if (present(Iresttime_u_in)) then + Iresttime_u(:,:) = Iresttime_u_in(:,:) + else + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + enddo ; enddo + endif + CS%num_col_u = 0 ; + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo @@ -512,9 +577,15 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + if (present(Iresttime_v_in)) then + Iresttime_v(:,:) = Iresttime_v_in(:,:) + else + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + enddo ; enddo + endif + CS%num_col_v = 0 ; + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -542,17 +613,31 @@ end subroutine initialize_ALE_sponge_varying !> Initialize diagnostics for the ALE_sponge module. ! GMM: this routine is not being used for now. -subroutine init_ALE_sponge_diags(Time, G, diag, CS) +subroutine init_ALE_sponge_diags(Time, G, diag, CS, US) type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type if (.not.associated(CS)) return CS%diag => diag + CS%id_sp_tendency(1) = -1 + CS%id_sp_tendency(1) = register_diag_field('ocean_model', 'sp_tendency_temp', diag%axesTL, Time, & + 'Time tendency due to temperature restoring', 'degC s-1',conversion=US%s_to_T) + CS%id_sp_tendency(2) = -1 + CS%id_sp_tendency(2) = register_diag_field('ocean_model', 'sp_tendency_salt', diag%axesTL, Time, & + 'Time tendency due to salinity restoring', 'g kg-1 s-1',conversion=US%s_to_T) + CS%id_sp_u_tendency = -1 + CS%id_sp_u_tendency = register_diag_field('ocean_model', 'sp_tendency_u', diag%axesCuL, Time, & + 'Zonal acceleration due to sponges', 'm s-2',conversion=US%L_T2_to_m_s2) + CS%id_sp_v_tendency = -1 + CS%id_sp_v_tendency = register_diag_field('ocean_model', 'sp_tendency_v', diag%axesCvL, Time, & + 'Meridional acceleration due to sponges', 'm s-2',conversion=US%L_T2_to_m_s2) + end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable @@ -573,7 +658,6 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) if (.not.associated(CS)) return CS%fldno = CS%fldno + 1 - if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & @@ -656,7 +740,6 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, CS%Ref_val(CS%fldno)%h(:,:) = 0.0 CS%var(CS%fldno)%p => f_ptr - end subroutine set_up_ALE_sponge_field_varying !> This subroutine stores the reference profile at u and v points for the variable @@ -665,14 +748,16 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), & - intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers. - real, dimension(SZI_(G),SZJB_(G),CS%nz_data), & - intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target, intent(in) :: u_ptr !< u pointer to the field to be damped - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target, intent(in) :: v_ptr !< v pointer to the field to be damped - - integer :: j, k, col + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers but + !! not to exceed the total number of model layers + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers but + !! not to exceed the number of model layers + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u pointer to the field to be damped + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v pointer to the field to be damped + + integer :: j, k, col, fld_sz(4) character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return @@ -697,7 +782,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, end subroutine set_up_ALE_sponge_vel_field_fixed -!> This subroutine stores the reference profile at uand v points for the variable +!> This subroutine stores the reference profile at u and v points for the variable !! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename_v, fieldname_v, & Time, G, GV, US, CS, u_ptr, v_ptr) @@ -706,79 +791,59 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename character(len=*), intent(in) :: filename_v !< File name for v field character(len=*), intent(in) :: fieldname_v !< Name of v variable in file type(time_type), intent(in) :: Time !< Model time - type(ocean_grid_type), intent(inout) :: G !< Ocean grid (in) - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid (in) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u pointer to the field to be damped (in). + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v pointer to the field to be damped (in). ! Local variables real, allocatable, dimension(:,:,:) :: u_val !< U field to be used in the sponge. - real, allocatable, dimension(:,:,:) :: mask_u !< U field mask for the sponge data. real, allocatable, dimension(:,:,:) :: v_val !< V field to be used in the sponge. - real, allocatable, dimension(:,:,:) :: mask_v !< V field mask for the sponge data. real, allocatable, dimension(:), target :: z_in, z_edges_in real :: missing_value + logical :: override integer :: j, k, col integer :: isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB integer, dimension(4) :: fld_sz character(len=256) :: mesg ! String for error messages - + type(axistype), dimension(4) :: axes_data + integer :: tmp + integer :: axis_sizes(4) if (.not.associated(CS)) return + override =.true. + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed isdB = G%isdB; iedB = G%iedB; jsdB = G%jsdB; jedB = G%jedB ! get a unique id for this field which will allow us to return an array ! containing time-interpolated values from an external file corresponding ! to the current model date. - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) + CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) 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) - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) + + CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) 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) - allocate( u_val(isdB:iedB,jsd:jed, fld_sz(3)) ) - allocate( mask_u(isdB:iedB,jsd:jed, fld_sz(3)) ) - allocate( v_val(isd:ied,jsdB:jedB, fld_sz(3)) ) - allocate( mask_v(isd:ied,jsdB:jedB, fld_sz(3)) ) - ! Interpolate external file data to the model grid - ! I am hard-wiring this call to assume that the input grid is zonally re-entrant - ! In the future, this should be generalized using an interface to return the - ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, u_val, mask_u, z_in, z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z, & - answers_2018=CS%hor_regrid_answers_2018) - !!! TODO: add a velocity interface! (mjh) - ! Interpolate external file data to the model grid - ! I am hard-wiring this call to assume that the input grid is zonally re-entrant - ! In the future, this should be generalized using an interface to return the - ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, v_val, mask_v, z_in, z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z, & - answers_2018=CS%hor_regrid_answers_2018) + ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u)) CS%Ref_val_u%p(:,:) = 0.0 - do col=1,CS%num_col_u - do k=1,fld_sz(3) - CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) - enddo - enddo + allocate(CS%Ref_val_u%h(fld_sz(3),CS%num_col_u) ) + CS%Ref_val_u%h(:,:) = 0.0 CS%var_u%p => u_ptr allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v)) CS%Ref_val_v%p(:,:) = 0.0 - do col=1,CS%num_col_v - do k=1,fld_sz(3) - CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) - enddo - enddo + allocate(CS%Ref_val_v%h(fld_sz(3),CS%num_col_v) ) + CS%Ref_val_v%h(:,:) = 0.0 CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_varying @@ -803,14 +868,19 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid 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(:,:,:) :: sp_val_u ! A temporary array for fields + real, allocatable, dimension(:,:,:) :: sp_val_v ! A temporary array for fields real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts + real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency diagnostics, + real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics + real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. ! Local variables for ALE remapping real, dimension(:), allocatable :: tmpT1d integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data integer :: col, total_sponge_cols real, allocatable, dimension(:), target :: z_in, z_edges_in - real :: missing_value + real :: missing_value, Idt real :: h_neglect, h_neglect_edge real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. integer :: nPoints @@ -818,6 +888,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return + Idt = 1.0/dt + if (.not.CS%remap_answers_2018) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then @@ -831,19 +903,19 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data - allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) ; sp_val(:,:,:) = 0.0 - allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) ; mask_z(:,:,:) = 0.0 + allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)); sp_val(:,:,:) = 0.0 + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)); mask_z(:,:,:) = 0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, .true., .false., .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answers_2018=CS%hor_regrid_answers_2018) + z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & + spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answers_2018=CS%hor_regrid_answers_2018) allocate( hsrc(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col i = CS%col_i(c) ; j = CS%col_j(c) - do k=1,nz_data ; CS%Ref_val(m)%p(k,c) = sp_val(i,j,k) ; enddo + 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. ; 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%bathyT(CS%col_i(c),CS%col_j(c)) ) @@ -863,7 +935,6 @@ 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 (mask_z(i,j,k)==0.) & if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & ! some confusion here about why the masks are not correct returning from horiz_interp ! reverting to using a minimum thickness criteria @@ -872,17 +943,21 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) enddo deallocate(sp_val, mask_z, hsrc, tmpT1d) enddo - else - nz_data = CS%nz_data endif - allocate(tmp_val2(nz_data)) - do c=1,CS%num_col - i = CS%col_i(c) ; j = CS%col_j(c) - damp = dt * CS%Iresttime_col(c) - I1pdamp = 1.0 / (1.0 + damp) - do k=1,nz ; h_col(k) = h(i,j,k) ; enddo - do m=1,CS%fldno + 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)) + if (CS%id_sp_tendency(m) > 0) then + allocate(tmp(G%isd:G%ied,G%jsd:G%jed,nz));tmp(:,:,:) = 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. + 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) 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, & @@ -891,102 +966,187 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) 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) endif - ! Backward Euler method - do k=1,CS%nz ; CS%var(m)%p(i,j,k) = I1pdamp * (CS%var(m)%p(i,j,k) + tmp_val1(k) * damp) ; enddo + !Backward Euler method + if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) + CS%var(m)%p(i,j,1:nz) = I1pdamp * (CS%var(m)%p(i,j,1:nz) + tmp_val1(1:nz) * damp) + if (CS%id_sp_tendency(m) > 0) & + tmp(i,j,1:CS%nz) = Idt*(CS%var(m)%p(i,j,1:nz) - tmp(i,j,1:nz)) enddo - enddo - ! for debugging - !c=CS%num_col - !do m=1,CS%fldno - ! write(*,*) 'APPLY SPONGE,m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1',& - ! m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1 - !enddo + if (CS%id_sp_tendency(m) > 0) then + call post_data(CS%id_sp_tendency(m), tmp, CS%diag) + deallocate(tmp) + endif + deallocate(tmp_val2) + enddo if (CS%sponge_uv) then + if (CS%time_varying_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") nz_data = CS%Ref_val_u%nz_data - allocate(sp_val(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + allocate(sp_val_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + sp_val(:,:,:) = 0.0 + sp_val_u(:,:,:) = 0.0 + mask_z(:,:,:) = 0.0 ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, .true., .false., .false., & - m_to_Z=US%m_to_Z, answers_2018=CS%hor_regrid_answers_2018) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - do c=1,CS%num_col - i = CS%col_i(c) ; j = CS%col_j(c) - do k=1,nz_data ; CS%Ref_val_u%p(k,c) = sp_val(i,j,k) ; enddo - enddo + z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & + spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& + answers_2018=CS%hor_regrid_answers_2018) - deallocate (sp_val, mask_z) + call pass_var(sp_val,G%Domain) + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + sp_val_u(I,j,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i+1,j,1:nz_data)) + enddo ; enddo + allocate( hsrc(nz_data) ) + allocate( tmpT1d(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. + i = CS%col_i_u(c) ; j = CS%col_j_u(c) + CS%Ref_val_u%p(1:nz_data,c) = sp_val_u(i,j,1:nz_data) + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + do k=1,nz_data + if (mask_z(i,j,k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) + tmpT1d(k) = sp_val_u(i,j,k) + elseif (k>1) then + zBottomOfCell = -G%bathyT(i,j) + tmpT1d(k) = tmpT1d(k-1) + else ! This next block should only ever be reached over land + tmpT1d(k) = -99.9 + endif + hsrc(k) = zTopOfCell - zBottomOfCell + if (hsrc(k)>0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_u%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + enddo + deallocate(sp_val, sp_val_u, mask_z, hsrc, tmpT1d) nz_data = CS%Ref_val_v%nz_data - allocate(sp_val(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + allocate(sp_val( G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + allocate(sp_val_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + sp_val(:,:,:) = 0.0 + sp_val_v(:,:,:) = 0.0 + mask_z(:,:,:) = 0.0 ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, .true., .false., .false., & - m_to_Z=US%m_to_Z, answers_2018=CS%hor_regrid_answers_2018) - -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - - do c=1,CS%num_col - i = CS%col_i(c) ; j = CS%col_j(c) - do k=1,nz_data ; CS%Ref_val_v%p(k,c) = sp_val(i,j,k) ; enddo + z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & + spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& + answers_2018=CS%hor_regrid_answers_2018) + call pass_var(sp_val,G%Domain) + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + sp_val_v(i,J,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i,j+1,1:nz_data)) + enddo ; enddo + !call pass_var(mask_z,G%Domain) + allocate( hsrc(nz_data) ) + allocate( tmpT1d(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. + i = CS%col_i_v(c) ; j = CS%col_j_v(c) + CS%Ref_val_v%p(1:nz_data,c) = sp_val_v(i,j,1:nz_data) + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + do k=1,nz_data + if (mask_z(i,j,k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) + tmpT1d(k) = sp_val_v(i,j,k) + elseif (k>1) then + zBottomOfCell = -G%bathyT(i,j) + tmpT1d(k) = tmpT1d(k-1) + else ! This next block should only ever be reached over land + tmpT1d(k) = -99.9 + endif + hsrc(k) = zTopOfCell - zBottomOfCell + if (hsrc(k)>0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_v%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) enddo - - deallocate (sp_val, mask_z) - - else - nz_data = CS%nz_data + deallocate(sp_val, sp_val_v, mask_z, hsrc, tmpT1d) endif + nz_data = CS%Ref_val_u%nz_data + allocate(tmp_val2(nz_data)) + if (CS%id_sp_u_tendency > 0) then + allocate(tmp_u(G%isdB:G%iedB,G%jsd:G%jed,nz));tmp_u(:,:,:)=0.0 + endif ! u points do c=1,CS%num_col_u I = CS%col_i_u(c) ; j = CS%col_j_u(c) damp = dt * CS%Iresttime_col_u(c) I1pdamp = 1.0 / (1.0 + damp) - do k=1,nz ; h_col(k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) ; enddo - if (CS%time_varying_sponges) nz_data = CS%Ref_val(m)%nz_data tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) + do k=1,nz + h_col(k) = 0.5 * (h(i,j,k) + h(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(:,c), tmp_val2, & + 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) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(:,c), tmp_val2, & + 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) 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 - do k=1,CS%nz ; CS%var_u%p(I,j,k) = I1pdamp * (CS%var_u%p(I,j,k) + tmp_val1(k) * damp) ; enddo + CS%var_u%p(i,j,1:nz) = I1pdamp * (CS%var_u%p(i,j,1:nz) + tmp_val1 * damp) + if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = Idt*(CS%var_u%p(i,j,1:nz) - tmp_u(i,j,1:nz)) enddo - + deallocate(tmp_val2) + if (CS%id_sp_u_tendency > 0) then + call post_data(CS%id_sp_u_tendency, tmp_u, CS%diag) + deallocate(tmp_u) + endif ! v points + if (CS%id_sp_v_tendency > 0) then + allocate(tmp_v(G%isd:G%ied,G%jsdB:G%jedB,nz));tmp_v(:,:,:)=0.0 + endif + nz_data = CS%Ref_val_v%nz_data + allocate(tmp_val2(nz_data)) do c=1,CS%num_col_v i = CS%col_i_v(c) ; j = CS%col_j_v(c) damp = dt * CS%Iresttime_col_v(c) I1pdamp = 1.0 / (1.0 + damp) - do k=1,nz ; h_col(k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) ; enddo + 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)) + enddo if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & + 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) else - call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_hv%p(:,c), tmp_val2, & + 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) 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 - do k=1,CS%nz ; CS%var_u%p(i,J,k) = I1pdamp * (CS%var_u%p(i,J,k) + tmp_val1(k) * damp) ; enddo + CS%var_v%p(i,j,1:nz) = I1pdamp * (CS%var_v%p(i,j,1:nz) + tmp_val1 * damp) + if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = Idt*(CS%var_v%p(i,j,1:nz) - tmp_v(i,j,1:nz)) enddo - + if (CS%id_sp_v_tendency > 0) then + call post_data(CS%id_sp_v_tendency, tmp_v, CS%diag) + deallocate(tmp_v) + endif + deallocate(tmp_val2) endif - deallocate(tmp_val2) + + end subroutine apply_ALE_sponge From b5158bb0705d098f6594abbd10250edcba23b316 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 4 Feb 2021 16:06:04 -0500 Subject: [PATCH 197/212] Create a MOM_diag_manager_infra module (#1309) This PR creates a new module, MOM_diag_manager_infra, which incorporates the previous module MOM_diag_manager, in order to isolate direct references to shared infrastructure and document all of the diagnostic interfaces that are used by MOM6. Some routines have been renamed to clearly differentiate them from the FMS diag_manager routines that they wrap. Co-authored-by: Marshall Ward Co-authored-by: Robert Hallberg --- src/diagnostics/MOM_obsolete_diagnostics.F90 | 31 +- src/framework/MOM_diag_manager.F90 | 164 ------- src/framework/MOM_diag_manager_infra.F90 | 437 ++++++++++++++++++ src/framework/MOM_diag_mediator.F90 | 154 +++--- src/framework/MOM_diag_remap.F90 | 6 +- src/ice_shelf/MOM_ice_shelf.F90 | 21 +- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 96 ++-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 5 +- 8 files changed, 595 insertions(+), 319 deletions(-) delete mode 100644 src/framework/MOM_diag_manager.F90 create mode 100644 src/framework/MOM_diag_manager_infra.F90 diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index bba8379bbb..8243b15cf7 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -4,8 +4,7 @@ module MOM_obsolete_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_manager, only : register_static_field_fms -use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_mediator, only : diag_ctrl, found_in_diagtable use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : param_file_type, log_version, get_param @@ -61,33 +60,5 @@ subroutine register_obsolete_diagnostics(param_file, diag) end subroutine register_obsolete_diagnostics -!> Fakes a register of a diagnostic to find out if an obsolete -!! parameter appears in the diag_table. -logical function found_in_diagtable(diag, varName, newVarName) - type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. - character(len=*), intent(in) :: varName !< The obsolete diagnostic name - character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic - ! Local - integer :: handle ! Integer handle returned from diag_manager - - ! We use register_static_field_fms() instead of register_static_field() so - ! that the diagnostic does not appear in the available diagnostics list. - handle = register_static_field_fms('ocean_model', varName, & - diag%axesT1%handles, 'Obsolete parameter', 'N/A') - - found_in_diagtable = (handle>0) - - if (handle>0 .and. is_root_pe()) then - if (present(newVarName)) then - call MOM_error(WARNING, 'MOM_obsolete_params: '// & - 'diag_table entry "'//trim(varName)//'" found. Use '// & - '"'//trim(newVarName)//'" instead.' ) - else - call MOM_error(WARNING, 'MOM_obsolete_params: '// & - 'diag_table entry "'//trim(varName)//'" is obsolete.' ) - endif - endif - -end function found_in_diagtable end module MOM_obsolete_diagnostics diff --git a/src/framework/MOM_diag_manager.F90 b/src/framework/MOM_diag_manager.F90 deleted file mode 100644 index 6519ffadb6..0000000000 --- a/src/framework/MOM_diag_manager.F90 +++ /dev/null @@ -1,164 +0,0 @@ -!> A simple (very thin) wrapper for the FMS diag_manager routines, with some name changes -module MOM_diag_manager - -! This file is part of MOM6. See LICENSE.md for the license. - -use diag_axis_mod, only : axis_init=>diag_axis_init, get_diag_axis_name, EAST, NORTH -use diag_data_mod, only : null_axis_id -use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND -use diag_manager_mod, only : 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_domain_infra, only : MOM_domain_type, domain2d -use MOM_error_infra, only : MOM_error=>MOM_err, FATAL -use MOM_time_manager, only : time_type - -implicit none ; private - -public :: diag_manager_init, diag_manager_end -public :: diag_axis_init, get_diag_axis_name, EAST, NORTH -public :: send_data, diag_field_add_attribute, DIAG_FIELD_NOT_FOUND -public :: register_diag_field_fms, register_static_field_fms, get_diag_field_id_fms - -!> A wrapper for register_diag_field_array() -interface register_diag_field_fms - module procedure register_diag_field_array_fms, register_diag_field_scalar_fms -end interface - -contains - -!> An integer handle for a diagnostic array returned by register_diag_field() -integer function register_diag_field_array_fms(module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or - !! "ice_shelf_model" - character(len=*), intent(in) :: field_name !< Name of the diagnostic field - integer, intent(in) :: axes(:) !< Container w/ up to 3 integer handles that - !! indicates axes for this field - type(time_type), intent(in) :: init_time !< Time at which a field is first available? - 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) :: range(2) !< Valid range of a variable (not used in MOM?) - 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?) - 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?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be - !! interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) - integer, optional, intent(in) :: area !< The FMS id of cell area - integer, optional, intent(in) :: volume !< The FMS id of cell volume - ! Local variables - - register_diag_field_array_fms = register_diag_field(module_name, field_name, axes, & - init_time, long_name=long_name, units=units, missing_value=missing_value, & - mask_variant=mask_variant, standard_name=standard_name, & - verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & - area=area, volume=volume, interp_method=interp_method) - -end function register_diag_field_array_fms - -!> An integer handle for a diagnostic scalar array returned by register_diag_field() -integer function register_diag_field_scalar_fms(module_name, field_name, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" - !! or "ice_shelf_model" - character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(time_type), intent(in) :: init_time !< Time at which a field is first available? - 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) :: range(2) !< Valid range of a variable (not used in MOM?) - 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?) - 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?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not - !! be interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) - integer, optional, intent(in) :: area !< The FMS id of cell area (not used for scalars) - integer, optional, intent(in) :: volume !< The FMS id of cell volume (not used for scalars) - ! Local variables - - register_diag_field_scalar_fms = register_diag_field(module_name, field_name, & - init_time, long_name=long_name, units=units, missing_value=missing_value, & - standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg) - -end function register_diag_field_scalar_fms - -!> diag_axis_init stores up the information for an axis that can be used for diagnostics and -!! returns an integer hadle for this axis. -integer function diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & - direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - diag_axis_init = null_axis_id - return - endif ; endif - - if (present(MOM_domain)) then - coarsening = 1 ; if (present(coarsen)) coarsening = coarsen - if (coarsening == 1) then - diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & - direction=direction, set_name=set_name, edges=edges, & - domain2=MOM_domain%mpp_domain, domain_position=position) - elseif (coarsening == 2) then - diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & - direction=direction, set_name=set_name, edges=edges, & - domain2=MOM_domain%mpp_domain_d2, domain_position=position) - else - call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") - endif - else - if (present(coarsen)) then ; if (coarsen /= 1) then - call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") - endif ; endif - diag_axis_init = axis_init(name, data, units, cart_name, long_name=long_name, & - direction=direction, set_name=set_name, edges=edges) - endif - -end function diag_axis_init - -!> \namespace mom_diag_manager -!! -!! This module simply wraps register_diag_field() from FMS's diag_manager_mod. -!! We used to be able to import register_diag_field and rename it to register_diag_field_fms -!! with a simple "use, only : register_diag_field_fms => register_diag_field" but PGI 16.5 -!! has a bug that refuses to compile this - earlier versions did work. - -end module MOM_diag_manager diff --git a/src/framework/MOM_diag_manager_infra.F90 b/src/framework/MOM_diag_manager_infra.F90 new file mode 100644 index 0000000000..7617d9ed91 --- /dev/null +++ b/src/framework/MOM_diag_manager_infra.F90 @@ -0,0 +1,437 @@ +!> A wrapper for the FMS diag_manager routines. This module should be the +!! only MOM6 module which imports the FMS shared infrastructure for +!! diagnostics. Pass through interfaces are being documented +!! here and renamed in order to clearly identify these APIs as being +!! consistent with the FMS infrastructure (Any future updates to +!! those APIs would be applied here). +module MOM_diag_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use diag_axis_mod, only : fms_axis_init=>diag_axis_init +use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name +use diag_axis_mod, only : EAST, NORTH +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 : 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 time_manager_mod, only : time_type +use MOM_domain_infra, only : MOM_domain_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING +implicit none ; private + + +!> transmit data for diagnostic output +interface register_diag_field_fms_wrapper + module procedure register_diag_field_fms_wrapper_scalar + module procedure register_diag_field_fms_wrapper_array +end interface register_diag_field_fms_wrapper + +!> transmit data for diagnostic output +interface send_data_fms_wrapper + module procedure send_data_fms_wrapper_0d + module procedure send_data_fms_wrapper_1d + module procedure send_data_fms_wrapper_2d + module procedure send_data_fms_wrapper_3d +#ifdef OVERLOAD_R8 + module procedure send_data_fms_wrapper_2d_r8 + module procedure send_data_fms_wrapper_3d_r8 +#endif +end interface send_data_fms_wrapper + +!> Add an attribute to a diagnostic field +interface MOM_diag_field_add_attribute + module procedure MOM_diag_field_add_attribute_scalar_r + module procedure MOM_diag_field_add_attribute_scalar_i + module procedure MOM_diag_field_add_attribute_scalar_c + module procedure MOM_diag_field_add_attribute_r1d + module procedure MOM_diag_field_add_attribute_i1d +end interface MOM_diag_field_add_attribute + + +! Public interfaces +public MOM_diag_axis_init +public get_MOM_diag_axis_name +public MOM_diag_manager_init +public MOM_diag_manager_end +public send_data_fms_wrapper +public MOM_diag_field_add_attribute +public register_diag_field_fms_wrapper +public register_static_field_fms_wrapper +public get_MOM_diag_field_id +! Public data +public null_axis_id +public DIAG_FIELD_NOT_FOUND +public EAST, NORTH + + +contains + +!> Initialize a diagnostic axis +integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + & direction, edges, set_name, coarsen, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain, domain_position=position) + elseif (coarsening == 2) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain_d2, domain_position=position) + else + call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") + endif + else + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") + endif ; endif + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function MOM_diag_axis_init + +!> Returns the short name of the axis +subroutine get_MOM_diag_axis_name(id, name) + integer, intent(in) :: id !< The axis numeric id + character(len=*), intent(out) :: name !< The short name of the axis + + call fms_get_diag_axis_name(id, name) + +end subroutine get_MOM_diag_axis_name + +!> Return a unique numeric ID field a module/field name combination. +integer function get_MOM_diag_field_id(module_name, field_name) + character(len=*), intent(in) :: module_name !< A module name string to query. + character(len=*), intent(in) :: field_name !< A field name string to query. + + + get_MOM_diag_field_id=-1 + get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) + +end function get_MOM_diag_field_id + +!> Initializes the diagnostic manager +subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics + !! The default uses the value contained in the + !! diag_table. Format is Y-M-D-H-M-S + character(len=*), intent(out), optional :: err_msg !< Error message. + call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) + +end subroutine MOM_diag_manager_init + +!> Close the diagnostic manager +subroutine MOM_diag_manager_end(time) + type(time_type), intent(in) :: time !< Model time at call to close. + + call FMS_diag_manager_end(time) + +end subroutine MOM_diag_manager_end + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_fms_wrapper_scalar(module_name, field_name, init_time, & + & long_name, units, missing_value, range, standard_name, do_not_log, err_msg, & + & area, volume, realm) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time. + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field metric. + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute. + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< Log message. + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute + + + register_diag_field_fms_wrapper_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, & + area, volume, realm) + +end function register_diag_field_fms_wrapper_scalar + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_fms_wrapper_array(module_name, field_name, axes, init_time, & + & long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & + & err_msg, interp_method, tile_count, & + & area, volume, realm) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, INTENT(in) :: axes(:) !< Diagnostic ID of 1 dimensional axis attributes for the field. + type(time_type), optional, intent(in) :: init_time !< The registration time. + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field metric. + real, optional, intent(in) :: missing_value !< Missing value attribute. + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time. + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< Not documented + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< Log message. + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute + + + register_diag_field_fms_wrapper_array = register_diag_field_fms(module_name, field_name, axes, init_time, & + & long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & + & err_msg, interp_method, tile_count, & + & area, volume, realm) + +end function register_diag_field_fms_wrapper_array + + +integer function register_static_field_fms_wrapper(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, do_not_log, interp_method,& + & tile_count, area, volume, realm) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, INTENT(in) :: axes(:) !< Diagnostic ID of 1 dimensional axis attributes for the field. + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field metric. + real, optional, intent(in) :: missing_value !< Missing value attribute. + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time. + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< Not documented + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute + + + register_static_field_fms_wrapper = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume, realm=realm) +end function register_static_field_fms_wrapper + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real, intent(in) :: field !< Floating point value being recorded + TYPE(time_type), intent(in), optional :: time !< Time slice for this record + CHARACTER(len=*), intent(out), optional :: err_msg !< An optional error message + + send_data_fms_wrapper_0d= send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_fms_wrapper_0d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real, dimension(:), intent(in) :: field !< A rank 1 array of floating point values being recorded + type (time_type), intent(in), optional :: time !< The time for the current record. + logical, intent(in), dimension(:), optional :: mask !< An optional rank 1 logical mask. + real, intent(in), dimension(:), optional :: rmask !< An optional rank 1 mask array + integer, intent(in), optional :: is_in !< An optional starting index for subsetting the data being recorded. + integer, intent(in), optional :: ie_in !< An optional end index for subsetting the data being recorded. + real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record + !! in the case where data a data reduction in time is being performed. + character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine. + + send_data_fms_wrapper_1d= send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + +end function send_data_fms_wrapper_1d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, & + & ie_in, je_in, weight, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real, dimension(:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + type (time_type), intent(in), optional :: time !< The time for the current record. + logical, intent(in), dimension(:,:), optional :: mask !< An optional rank 1 logical mask. + real, intent(in), dimension(:,:), optional :: rmask !< An optional rank 1 mask array + integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. + integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. + integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. + integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. + real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record + !! in the case where data a data reduction in time is being performed. + character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine. + + send_data_fms_wrapper_2d= send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_fms_wrapper_2d + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_2d_r8(diag_field_id, field, time, is_in, js_in, mask, rmask, & + & ie_in, je_in, weight, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real(kind=8), dimension(:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + type (time_type), intent(in), optional :: time !< The time for the current record. + logical, intent(in), dimension(:,:), optional :: mask !< An optional rank 1 logical mask. + real, intent(in), dimension(:,:), optional :: rmask !< An optional rank 1 mask array + integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. + integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. + integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. + integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. + real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record + !! in the case where data a data reduction in time is being performed. + character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine. + + send_data_fms_wrapper_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_fms_wrapper_2d_r8 +#endif + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + & ie_in, je_in, ke_in, weight, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + type (time_type), intent(in), optional :: time !< The time for the current record. + logical, intent(in), dimension(:,:,:), optional :: mask !< An optional rank 1 logical mask. + real, intent(in), dimension(:,:,:), optional :: rmask !< An optional rank 1 mask array + integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. + integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. + integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. + integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. + integer, intent(in), optional :: ks_in !< An optional k starting index for subsetting the data being recorded. + integer, intent(in), optional :: ke_in !< An optional k end index for subsetting the data being recorded. + real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record + !! in the case where data a data reduction in time is being performed. + character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine. + + send_data_fms_wrapper_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_fms_wrapper_3d + + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_fms_wrapper_3d_r8(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + & ie_in, je_in, ke_in, weight, err_msg) + integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager + real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + type (time_type), intent(in), optional :: time !< The time for the current record. + logical, intent(in), dimension(:,:,:), optional :: mask !< An optional rank 1 logical mask. + real, intent(in), dimension(:,:,:), optional :: rmask !< An optional rank 1 mask array + integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. + integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. + integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. + integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. + integer, intent(in), optional :: ks_in !< An optional k starting index for subsetting the data being recorded. + integer, intent(in), optional :: ke_in !< An optional k end index for subsetting the data being recorded. + real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record + !! in the case where data a data reduction in time is being performed. + character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine. + + send_data_fms_wrapper_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_fms_wrapper_3d_r8 +#endif + +!> Add a real scalar attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< A unique numeric field id + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_r + +!> Add an integer attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< A unique numeric field id + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_i + +!> Add a character string attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< A unique numeric field id + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_c + +!> Add a real list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< A unique numeric field id + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_r1d + +!> Add a integer list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< A unique numeric field id + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< A integer list of values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_i1d + + + +end module MOM_diag_manager_infra diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 108bd389e6..90496f05a7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -9,11 +9,11 @@ module MOM_diag_mediator use MOM_coms, only : PE_here 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_manager, only : diag_manager_init, diag_manager_end -use MOM_diag_manager, only : diag_axis_init, get_diag_axis_name -use MOM_diag_manager, only : send_data, diag_field_add_attribute, EAST, NORTH -use MOM_diag_manager, only : register_diag_field_fms, register_static_field_fms -use MOM_diag_manager, only : get_diag_field_id_fms, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end +use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name +use MOM_diag_manager_infra, only : send_data_fms_wrapper, MOM_diag_field_add_attribute, EAST, NORTH +use MOM_diag_manager_infra, only : register_diag_field_fms_wrapper, register_static_field_fms_wrapper +use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND 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 @@ -56,6 +56,7 @@ module MOM_diag_mediator public diag_grid_storage_init, diag_grid_storage_end public diag_copy_diag_to_storage, diag_copy_storage_to_diag public diag_save_grids, diag_restore_grids +public found_in_diagtable !> Make a diagnostic available for averaging or output. interface post_data @@ -1270,9 +1271,9 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) if (diag_cs%diag_as_chksum) then call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) elseif (is_stat) then - used = send_data(diag%fms_diag_id, locfield) + used = send_data_fms_wrapper(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end) + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end) endif diag => diag%next enddo @@ -1322,9 +1323,9 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) if (diag_cs%diag_as_chksum) then call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) elseif (is_stat) then - used = send_data(diag%fms_diag_id, locfield) + used = send_data_fms_wrapper(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int) + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) @@ -1478,24 +1479,24 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then call assert(size(locfield) == size(locmask), & 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else - used = send_data(diag%fms_diag_id, locfield, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=locmask) else - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int) endif @@ -1766,24 +1767,24 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then call assert(size(locfield) == size(locmask), & 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else - used = send_data(diag%fms_diag_id, locfield, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=locmask) else - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int) endif @@ -1849,7 +1850,7 @@ subroutine post_xy_average(diag_cs, diag, field) call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', & logunit=diag_CS%chksum_iounit) else - used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, & + used = send_data_fms_wrapper(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, & weight=diag_cs%time_int, mask=averaged_mask) endif end subroutine post_xy_average @@ -2390,13 +2391,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, ! If interp_method is provided we must use it if (area_id>0) then if (volume_id>0) then - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id) else - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2404,13 +2405,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, endif else if (volume_id>0) then - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count, volume=volume_id) else - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2421,13 +2422,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, ! If interp_method is not provided and the field is not at an h-point then interp_method='none' if (area_id>0) then if (volume_id>0) then - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method='none', tile_count=tile_count, area=area_id, volume=volume_id) else - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2435,13 +2436,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, endif else if (volume_id>0) then - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_Wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method='none', tile_count=tile_count, volume=volume_id) else - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2578,22 +2579,22 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & 'Individual direction cell method was specified along with a "cell_methods" string.') endif if (len(trim(cell_methods))>0) then - call diag_field_add_attribute(id, 'cell_methods', trim(cell_methods)) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(cell_methods)) ostring = trim(cell_methods) endif else if (present(x_cell_method)) then if (len(trim(x_cell_method))>0) then - call get_diag_axis_name(axes%handles(1), axis_name) - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method) if (trim(x_cell_method)=='mean') x_mean=.true. if (trim(x_cell_method)=='sum') x_sum=.true. endif else if (len(trim(axes%x_cell_method))>0) then - call get_diag_axis_name(axes%handles(1), axis_name) - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method)) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%x_cell_method) if (trim(axes%x_cell_method)=='mean') x_mean=.true. if (trim(axes%x_cell_method)=='sum') x_sum=.true. @@ -2601,16 +2602,16 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & endif if (present(y_cell_method)) then if (len(trim(y_cell_method))>0) then - call get_diag_axis_name(axes%handles(2), axis_name) - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(y_cell_method) if (trim(y_cell_method)=='mean') y_mean=.true. if (trim(y_cell_method)=='sum') y_sum=.true. endif else if (len(trim(axes%y_cell_method))>0) then - call get_diag_axis_name(axes%handles(2), axis_name) - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method)) + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%y_cell_method) if (trim(axes%y_cell_method)=='mean') y_mean=.true. if (trim(axes%y_cell_method)=='sum') y_sum=.true. @@ -2621,39 +2622,39 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & 'Vertical cell method was specified along with the vertically extensive flag.') if (len(trim(v_cell_method))>0) then if (axes%rank==1) then - call get_diag_axis_name(axes%handles(1), axis_name) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) elseif (axes%rank==3) then - call get_diag_axis_name(axes%handles(3), axis_name) + call get_MOM_diag_axis_name(axes%handles(3), axis_name) endif - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(v_cell_method)) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(v_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method) endif elseif (present(v_extensive)) then if (v_extensive) then if (axes%rank==1) then - call get_diag_axis_name(axes%handles(1), axis_name) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) elseif (axes%rank==3) then - call get_diag_axis_name(axes%handles(3), axis_name) + call get_MOM_diag_axis_name(axes%handles(3), axis_name) endif - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' endif else if (len(trim(axes%v_cell_method))>0) then if (axes%rank==1) then - call get_diag_axis_name(axes%handles(1), axis_name) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) elseif (axes%rank==3) then - call get_diag_axis_name(axes%handles(3), axis_name) + call get_MOM_diag_axis_name(axes%handles(3), axis_name) endif - call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%v_cell_method)) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%v_cell_method)) ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%v_cell_method) endif endif if (x_mean .and. y_mean) then - call diag_field_add_attribute(id, 'cell_methods', 'area:mean') + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:mean') ostring = trim(adjustl(ostring))//' area:mean' elseif (x_sum .and. y_sum) then - call diag_field_add_attribute(id, 'cell_methods', 'area:sum') + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:sum') ostring = trim(adjustl(ostring))//' area:sum' endif endif @@ -2702,7 +2703,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & fms_id = diag_cs%num_chksum_diags + 1 diag_cs%num_chksum_diags = fms_id else - fms_id = register_diag_field_fms(module_name, field_name, init_time, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, init_time, & long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, standard_name=standard_name, do_not_log=do_not_log, & err_msg=err_msg) @@ -2733,7 +2734,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name - fms_id = register_diag_field_fms(module_name, cmor_field_name, init_time, & + fms_id = register_diag_field_fms_wrapper(module_name, cmor_field_name, init_time, & long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & missing_value=MOM_missing_value, range=range, & standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg) @@ -2816,7 +2817,7 @@ function register_static_field(module_name, field_name, axes, & fms_id = diag_cs%num_chksum_diags + 1 diag_cs%num_chksum_diags = fms_id else - fms_id = register_static_field_fms(module_name, field_name, axes%handles, & + fms_id = register_static_field_fms_wrapper(module_name, field_name, axes%handles, & long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & do_not_log=do_not_log, & @@ -2835,17 +2836,17 @@ function register_static_field(module_name, field_name, axes, & diag%axes => axes else if (present(x_cell_method)) then - call get_diag_axis_name(axes%handles(1), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', & + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & trim(axis_name)//':'//trim(x_cell_method)) endif if (present(y_cell_method)) then - call get_diag_axis_name(axes%handles(2), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', & + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & trim(axis_name)//':'//trim(y_cell_method)) endif if (present(area_cell_method)) then - call diag_field_add_attribute(fms_id, 'cell_methods', & + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & 'area:'//trim(area_cell_method)) endif endif @@ -2868,7 +2869,7 @@ function register_static_field(module_name, field_name, axes, & if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name - fms_id = register_static_field_fms(module_name, cmor_field_name, & + fms_id = register_static_field_fms_wrapper(module_name, cmor_field_name, & axes%handles, long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & @@ -2882,15 +2883,15 @@ function register_static_field(module_name, field_name, axes, & cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) if (present(conversion)) cmor_diag%conversion_factor = conversion if (present(x_cell_method)) then - call get_diag_axis_name(axes%handles(1), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) endif if (present(y_cell_method)) then - call get_diag_axis_name(axes%handles(2), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) endif if (present(area_cell_method)) then - call diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) endif endif endif @@ -3007,7 +3008,7 @@ subroutine diag_mediator_infrastructure_init(err_msg) ! This subroutine initializes the FMS diag_manager. character(len=*), optional, intent(out) :: err_msg !< An error message - call diag_manager_init(err_msg=err_msg) + call MOM_diag_manager_init(err_msg=err_msg) end subroutine diag_mediator_infrastructure_init !> diag_mediator_init initializes the MOM diag_mediator and opens the available @@ -3425,7 +3426,7 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) #endif if (present(end_diag_manager)) then - if (end_diag_manager) call diag_manager_end(time) + if (end_diag_manager) call MOM_diag_manager_end(time) endif end subroutine diag_mediator_end @@ -4300,4 +4301,33 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ enddo ; enddo ; enddo end subroutine downsample_mask_3d +!> Fakes a register of a diagnostic to find out if an obsolete +!! parameter appears in the diag_table. +logical function found_in_diagtable(diag, varName, newVarName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic + ! Local + integer :: handle ! Integer handle returned from diag_manager + + ! We use register_static_field_fms() instead of register_static_field() so + ! that the diagnostic does not appear in the available diagnostics list. + handle = register_static_field_fms_wrapper('ocean_model', varName, & + diag%axesT1%handles, 'Obsolete parameter', 'N/A') + + found_in_diagtable = (handle>0) + + if (handle>0 .and. is_root_pe()) then + if (present(newVarName)) then + call MOM_error(WARNING, 'MOM_obsolete_params: '// & + 'diag_table entry "'//trim(varName)//'" found. Use '// & + '"'//trim(newVarName)//'" instead.' ) + else + call MOM_error(WARNING, 'MOM_obsolete_params: '// & + 'diag_table entry "'//trim(varName)//'" is obsolete.' ) + endif + endif + +end function found_in_diagtable + end module MOM_diag_mediator diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 4bea1fc5ae..d8a098d12c 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -61,7 +61,7 @@ module MOM_diag_remap use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING use MOM_debugging, only : check_column_integrals -use MOM_diag_manager, only : diag_axis_init +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 @@ -222,10 +222,10 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) interfaces(:) = getCoordinateInterfaces(remap_cs%regrid_cs) layers(:) = 0.5 * ( interfaces(1:remap_cs%nz) + interfaces(2:remap_cs%nz+1) ) - remap_cs%interface_axes_id = diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_i', & + remap_cs%interface_axes_id = MOM_diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_i', & interfaces, trim(units), 'z', & trim(longname)//' at interface', direction=-1) - remap_cs%layer_axes_id = diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_l', & + remap_cs%layer_axes_id = MOM_diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_l', & layers, trim(units), 'z', & trim(longname)//' at cell center', direction=-1, & edges=remap_cs%interface_axes_id) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 4149e1be01..d6390c9453 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -10,11 +10,14 @@ module MOM_ice_shelf use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_coms, only : num_PEs use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl -use MOM_IS_diag_mediator, only : post_data, register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr -use MOM_IS_diag_mediator, only : set_axes_info, diag_ctrl, time_type -use MOM_IS_diag_mediator, only : diag_mediator_init, diag_mediator_end, set_diag_mediator_grid +use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +use MOM_IS_diag_mediator, only : set_IS_axes_info, diag_ctrl, time_type +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end +use MOM_IS_diag_mediator, only : set_IS_diag_mediator_grid use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging -use MOM_IS_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_close_registration +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_infrastructure_init +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_close_registration use MOM_domains, only : MOM_domains_init, pass_var, pass_vector, clone_MOM_domain use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -1232,7 +1235,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! MOM's grid and infrastructure. call Get_MOM_Input(dirs=dirs) - call diag_mediator_infrastructure_init() + call MOM_IS_diag_mediator_infrastructure_init() ! Determining the internal unit scaling factors for this run. call unit_scaling_init(param_file, CS%US) @@ -1301,10 +1304,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, G => CS%Grid ; CS%Grid_in => CS%Grid allocate(CS%diag) - call diag_mediator_init(G, param_file, CS%diag, component='MOM_IceShelf') + call MOM_IS_diag_mediator_init(G, param_file, CS%diag, component='MOM_IceShelf') ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. - call set_axes_info(G, param_file, CS%diag) + call set_IS_axes_info(G, param_file, CS%diag) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1803,7 +1806,7 @@ 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') endif - call diag_mediator_close_registration(CS%diag) + call MOM_IS_diag_mediator_close_registration(CS%diag) if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (present(forces_in)) call initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) @@ -2069,7 +2072,7 @@ subroutine ice_shelf_end(CS) if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) - call diag_mediator_end(CS%diag) + call MOM_IS_diag_mediator_end(CS%diag) deallocate(CS) end subroutine ice_shelf_end diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 4955dd291a..dbf4037a35 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -4,8 +4,10 @@ module MOM_IS_diag_mediator ! This file is a part of SIS2. See LICENSE.md for the license. use MOM_coms, only : PE_here -use MOM_diag_manager, only : diag_manager_init, send_data, diag_axis_init, EAST, NORTH -use MOM_diag_manager, only : register_diag_field_fms, register_static_field_fms +use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_fms_wrapper, MOM_diag_axis_init +use MOM_diag_manager_infra, only : EAST, NORTH +use MOM_diag_manager_infra, only : register_static_field_fms_wrapper +use MOM_diag_manager_infra, only : register_diag_field_fms_wrapper use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -15,19 +17,15 @@ module MOM_IS_diag_mediator implicit none ; private -public diag_mediator_infrastructure_init -public set_axes_info, post_data, register_MOM_IS_diag_field, time_type +public MOM_IS_diag_mediator_infrastructure_init +public set_IS_axes_info, post_IS_data, register_MOM_IS_diag_field, time_type +public register_MOM_IS_static_field public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, disable_averaging, query_averaging_enabled public enable_averages -public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid -public diag_mediator_close_registration, get_diag_time_end -public diag_axis_init, register_static_field - -!> Make a diagnostic available for averaging or output. -!interface post_data -! module procedure post_data_2d -!end interface post_data +public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid +public MOM_IS_diag_mediator_close_registration, get_diag_time_end +public MOM_diag_axis_init, register_static_field_fms_wrapper !> 2D/3D axes type to contain 1D axes handles and pointers to masks type, public :: axesType @@ -98,7 +96,7 @@ module MOM_IS_diag_mediator contains !> Set up the grid and axis information for use by the ice shelf model. -subroutine set_axes_info(G, param_file, diag_cs, axes_set_name) +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 @@ -150,21 +148,21 @@ subroutine set_axes_info(G, param_file, diag_cs, axes_set_name) endif if (G%symmetric) then - id_xq = diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) - id_yq = diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) else - id_xq = diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) - id_yq = diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) endif - id_xh = diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'T point nominal longitude', G%Domain, set_name=set_name) - id_yh = diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & 'T point nominal latitude', G%Domain, set_name=set_name) ! Axis groupings for 2-D arrays. @@ -173,7 +171,7 @@ subroutine set_axes_info(G, param_file, diag_cs, axes_set_name) call defineAxes(diag_cs, [id_xq, id_yh], diag_cs%axesCu1) call defineAxes(diag_cs, [id_xh, id_yq], diag_cs%axesCv1) -end subroutine set_axes_info +end subroutine set_IS_axes_info !> Define an a group of axes from a list of handles subroutine defineAxes(diag_cs, handles, axes) @@ -194,17 +192,17 @@ subroutine defineAxes(diag_cs, handles, axes) end subroutine defineAxes !> Set up the current grid for the diag mediator -subroutine set_diag_mediator_grid(G, diag_cs) +subroutine set_IS_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed -end subroutine set_diag_mediator_grid +end subroutine set_IS_diag_mediator_grid !> Offer a 2d diagnostic field for output or averaging -subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) +subroutine post_IS_data(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, target, intent(in) :: field(:,:) !< The 2-d array being offered for output or averaging. @@ -226,7 +224,7 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) ! Get a pointer to the diag type for this id, and the FMS-level diag id. call assert(diag_field_id < diag_cs%next_free_diag_id, & - 'post_data: Unregistered diagnostic id') + 'post_IS_data: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) fms_diag_id = diag%fms_diag_id @@ -291,25 +289,25 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) if (is_stat) then if (present(mask)) then - used = send_data(fms_diag_id, locfield, & + used = send_data_fms_wrapper(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, mask=mask) elseif(i_data .and. associated(diag%mask2d)) then ! used = send_data(fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d) - used = send_data(fms_diag_id, locfield, & + used = send_data_fms_wrapper(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then ! used = send_data(fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d_comp) - used = send_data(fms_diag_id, locfield, & + used = send_data_fms_wrapper(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) else - used = send_data(fms_diag_id, locfield, & + used = send_data_fms_wrapper(fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (present(mask)) then - used = send_data(fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, mask=mask) ! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & @@ -319,18 +317,18 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) ! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & ! weight=diag_cs%time_int, rmask=diag%mask2d) - used = send_data(fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then ! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & ! weight=diag_cs%time_int, rmask=diag%mask2d_comp) - used = send_data(fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int) else - used = send_data(fms_diag_id, locfield, diag_cs%time_end, & + used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int) endif @@ -338,7 +336,7 @@ subroutine post_data(diag_field_id, field, diag_cs, is_static, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) ) deallocate( locfield ) -end subroutine post_data +end subroutine post_IS_data !> Enable the accumulation of time averages over the specified time interval. @@ -396,12 +394,12 @@ logical function query_averaging_enabled(diag_cs, time_int, time_end) query_averaging_enabled = diag_cs%ave_enabled end function query_averaging_enabled -subroutine diag_mediator_infrastructure_init(err_msg) +subroutine MOM_IS_diag_mediator_infrastructure_init(err_msg) ! This subroutine initializes the FMS diag_manager. character(len=*), optional, intent(out) :: err_msg !< An error message - call diag_manager_init(err_msg=err_msg) -end subroutine diag_mediator_infrastructure_init + call MOM_diag_manager_init(err_msg=err_msg) +end subroutine MOM_IS_diag_mediator_infrastructure_init !> diag_mediator_init initializes the MOM diag_mediator and opens the available @@ -431,7 +429,7 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with - !! post_data calls (not used in MOM?) + !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) 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 @@ -455,7 +453,7 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & diag_cs => axes%diag_cs primary_id = -1 - fms_id = register_diag_field_fms(module_name, field_name, axes%handles, & + fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -513,7 +511,7 @@ 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 -function register_static_field(module_name, field_name, axes, & +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) integer :: register_static_field !< The returned diagnostic handle @@ -526,7 +524,7 @@ function register_static_field(module_name, field_name, axes, & real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with - !! post_data calls (not used in MOM?) + !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not !! be interpolated as a scalar @@ -544,7 +542,7 @@ function register_static_field(module_name, field_name, axes, & diag_cs => axes%diag_cs primary_id = -1 - fms_id = register_static_field_fms(module_name, field_name, axes%handles, & + fms_id = register_static_field_fms_wrapper(module_name, field_name, axes%handles, & long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & do_not_log=do_not_log, & @@ -556,7 +554,7 @@ function register_static_field(module_name, field_name, axes, & register_static_field = primary_id -end function register_static_field +end function register_MOM_IS_static_field !> Add a description of an option to the documentation file subroutine describe_option(opt_name, value, diag_CS) @@ -596,7 +594,7 @@ function i2s(a, n_in) end function i2s !> Initialize the MOM_IS diag_mediator and opens the available diagnostics file. -subroutine diag_mediator_init(G, param_file, diag_cs, component, err_msg, & +subroutine MOM_IS_diag_mediator_init(G, param_file, diag_cs, component, err_msg, & doc_file_dir) 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 @@ -617,7 +615,7 @@ subroutine diag_mediator_init(G, param_file, diag_cs, component, err_msg, & character(len=40) :: doc_file_param character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. - call diag_manager_init(err_msg=err_msg) + call MOM_diag_manager_init(err_msg=err_msg) ! Allocate list of all diagnostics allocate(diag_cs%diags(DIAG_ALLOC_CHUNK_SIZE)) @@ -675,7 +673,7 @@ subroutine diag_mediator_init(G, param_file, diag_cs, component, err_msg, & call diag_masks_set(G, -1.0e34, diag_cs) -end subroutine diag_mediator_init +end subroutine MOM_IS_diag_mediator_init subroutine diag_masks_set(G, missing_value, diag_cs) ! Setup the 2d masks for diagnostics @@ -703,24 +701,24 @@ subroutine diag_masks_set(G, missing_value, diag_cs) end subroutine diag_masks_set !> Prevent the registration of additional diagnostics, so that the creation of files can occur -subroutine diag_mediator_close_registration(diag_CS) +subroutine MOM_IS_diag_mediator_close_registration(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output if (diag_CS%doc_unit > -1) then close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2 endif -end subroutine diag_mediator_close_registration +end subroutine MOM_IS_diag_mediator_close_registration !> Deallocate memory associated with the MOM_IS diag mediator -subroutine diag_mediator_end(diag_CS) +subroutine MOM_IS_diag_mediator_end(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output if (diag_CS%doc_unit > -1) then close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3 endif -end subroutine diag_mediator_end +end subroutine MOM_IS_diag_mediator_end !> Allocate a new diagnostic id, noting that it may be necessary to expand the diagnostics array. function get_new_diag_id(diag_cs) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index decdbf2e92..a70ae45137 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -6,8 +6,9 @@ module MOM_ice_shelf_dynamics use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE -use MOM_IS_diag_mediator, only : post_data, register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr -use MOM_IS_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid +use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +!use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER From 77649b22e71c6927e81cbeb7a773df20ee704936 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Feb 2021 16:26:41 -0500 Subject: [PATCH 198/212] +Cleanup of MOM_diag_manager_infra interfaces Renamed the interfaces send_data_fms_wrapper to send_data_infra, and register_..._field_fms_wrapper to register_..._field_infra. Also removed some of the optional arguments from these interfaces that are never used in MOM6 and rearranged the order of the optional arguments to send_data_infra to make more sense given how they are used in MOM6. Also regularized the formatting of the argument descriptions in MOM_diag_manager_infra.F90 to match the patterns elsewhere in the MOM6 code and corrected some incorrect comments. In addition, removed the error messages about obsolete diagnostics from found_in_table() and put them back into the MOM_obsolete_diagnostics module in the new local subroutine diag_found(). All answers are bitwise identical, although there are some interface changes. --- src/diagnostics/MOM_obsolete_diagnostics.F90 | 56 ++- src/framework/MOM_diag_manager_infra.F90 | 426 +++++++++--------- src/framework/MOM_diag_mediator.F90 | 130 +++--- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 74 +-- 4 files changed, 339 insertions(+), 347 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 8243b15cf7..86034292b5 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -35,30 +35,50 @@ subroutine register_obsolete_diagnostics(param_file, diag) foundEntry = .false. ! Each obsolete entry, with replacement name is available. - if (found_in_diagtable(diag, 'Net_Heat', 'net_heat_surface or net_heat_coupler')) foundEntry = .true. - if (found_in_diagtable(diag, 'PmE', 'PRCmE')) foundEntry = .true. - if (found_in_diagtable(diag, 'froz_precip', 'fprec')) foundEntry = .true. - if (found_in_diagtable(diag, 'liq_precip', 'lprec')) foundEntry = .true. - if (found_in_diagtable(diag, 'virt_precip', 'vprec')) foundEntry = .true. - if (found_in_diagtable(diag, 'froz_runoff', 'frunoff')) foundEntry = .true. - if (found_in_diagtable(diag, 'liq_runoff', 'lrunoff')) foundEntry = .true. - if (found_in_diagtable(diag, 'calving_heat_content', 'heat_content_frunoff')) foundEntry = .true. - if (found_in_diagtable(diag, 'precip_heat_content', 'heat_content_lprec')) foundEntry = .true. - if (found_in_diagtable(diag, 'evap_heat_content', 'heat_content_massout')) foundEntry = .true. - if (found_in_diagtable(diag, 'runoff_heat_content', 'heat_content_lrunoff')) foundEntry = .true. - if (found_in_diagtable(diag, 'latent_fprec')) foundEntry = .true. - if (found_in_diagtable(diag, 'latent_calve')) foundEntry = .true. - if (found_in_diagtable(diag, 'heat_rest', 'heat_restore')) foundEntry = .true. - if (found_in_diagtable(diag, 'KPP_dTdt', 'KPP_NLT_dTdt')) foundEntry = .true. - if (found_in_diagtable(diag, 'KPP_dSdt', 'KPP_NLT_dSdt')) foundEntry = .true. + if (diag_found(diag, 'Net_Heat', 'net_heat_surface or net_heat_coupler')) foundEntry = .true. + if (diag_found(diag, 'PmE', 'PRCmE')) foundEntry = .true. + if (diag_found(diag, 'froz_precip', 'fprec')) foundEntry = .true. + if (diag_found(diag, 'liq_precip', 'lprec')) foundEntry = .true. + if (diag_found(diag, 'virt_precip', 'vprec')) foundEntry = .true. + if (diag_found(diag, 'froz_runoff', 'frunoff')) foundEntry = .true. + if (diag_found(diag, 'liq_runoff', 'lrunoff')) foundEntry = .true. + if (diag_found(diag, 'calving_heat_content', 'heat_content_frunoff')) foundEntry = .true. + if (diag_found(diag, 'precip_heat_content', 'heat_content_lprec')) foundEntry = .true. + if (diag_found(diag, 'evap_heat_content', 'heat_content_massout')) foundEntry = .true. + if (diag_found(diag, 'runoff_heat_content', 'heat_content_lrunoff')) foundEntry = .true. + if (diag_found(diag, 'latent_fprec')) foundEntry = .true. + if (diag_found(diag, 'latent_calve')) foundEntry = .true. + if (diag_found(diag, 'heat_rest', 'heat_restore')) foundEntry = .true. + if (diag_found(diag, 'KPP_dTdt', 'KPP_NLT_dTdt')) foundEntry = .true. + if (diag_found(diag, 'KPP_dSdt', 'KPP_NLT_dSdt')) foundEntry = .true. if (causeFatal) then; errType = FATAL else ; errType = WARNING ; endif if (foundEntry .and. is_root_pe()) & - call MOM_error(errType, 'MOM_obsolete_diagnostics: '//& - 'Obsolete diagnostics found in diag_table') + call MOM_error(errType, 'MOM_obsolete_diagnostics: Obsolete diagnostics found in diag_table.') end subroutine register_obsolete_diagnostics +!> Determines whether an obsolete parameter appears in the diag_table. +logical function diag_found(diag, varName, newVarName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic + ! Local + integer :: handle ! Integer handle returned from diag_manager + + diag_found = found_in_diagtable(diag, varName) + + if (diag_found .and. is_root_pe()) then + if (present(newVarName)) then + call MOM_error(WARNING, 'MOM_obsolete_params: '//'diag_table entry "'// & + trim(varName)//'" found. Use ''"'//trim(newVarName)//'" instead.' ) + else + call MOM_error(WARNING, 'MOM_obsolete_params: '//'diag_table entry "'// & + trim(varName)//'" is obsolete.' ) + endif + endif + +end function diag_found end module MOM_obsolete_diagnostics diff --git a/src/framework/MOM_diag_manager_infra.F90 b/src/framework/MOM_diag_manager_infra.F90 index 7617d9ed91..702c464814 100644 --- a/src/framework/MOM_diag_manager_infra.F90 +++ b/src/framework/MOM_diag_manager_infra.F90 @@ -23,26 +23,23 @@ module MOM_diag_manager_infra use time_manager_mod, only : time_type use MOM_domain_infra, only : MOM_domain_type use MOM_error_handler, only : MOM_error, FATAL, WARNING -implicit none ; private +implicit none ; private !> transmit data for diagnostic output -interface register_diag_field_fms_wrapper - module procedure register_diag_field_fms_wrapper_scalar - module procedure register_diag_field_fms_wrapper_array -end interface register_diag_field_fms_wrapper +interface register_diag_field_infra + module procedure register_diag_field_infra_scalar + module procedure register_diag_field_infra_array +end interface register_diag_field_infra !> transmit data for diagnostic output -interface send_data_fms_wrapper - module procedure send_data_fms_wrapper_0d - module procedure send_data_fms_wrapper_1d - module procedure send_data_fms_wrapper_2d - module procedure send_data_fms_wrapper_3d +interface send_data_infra + module procedure send_data_infra_0d, send_data_infra_1d + module procedure send_data_infra_2d, send_data_infra_3d #ifdef OVERLOAD_R8 - module procedure send_data_fms_wrapper_2d_r8 - module procedure send_data_fms_wrapper_3d_r8 + module procedure send_data_infra_2d_r8, send_data_infra_3d_r8 #endif -end interface send_data_fms_wrapper +end interface send_data_infra !> Add an attribute to a diagnostic field interface MOM_diag_field_add_attribute @@ -59,10 +56,10 @@ module MOM_diag_manager_infra public get_MOM_diag_axis_name public MOM_diag_manager_init public MOM_diag_manager_end -public send_data_fms_wrapper +public send_data_infra public MOM_diag_field_add_attribute -public register_diag_field_fms_wrapper -public register_static_field_fms_wrapper +public register_diag_field_infra +public register_static_field_infra public get_MOM_diag_field_id ! Public data public null_axis_id @@ -131,7 +128,7 @@ end function MOM_diag_axis_init !> Returns the short name of the axis subroutine get_MOM_diag_axis_name(id, name) - integer, intent(in) :: id !< The axis numeric id + integer, intent(in) :: id !< The axis numeric id character(len=*), intent(out) :: name !< The short name of the axis call fms_get_diag_axis_name(id, name) @@ -144,18 +141,18 @@ integer function get_MOM_diag_field_id(module_name, field_name) character(len=*), intent(in) :: field_name !< A field name string to query. - get_MOM_diag_field_id=-1 + get_MOM_diag_field_id = -1 get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) end function get_MOM_diag_field_id !> Initializes the diagnostic manager subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) - integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics !! The default uses the value contained in the !! diag_table. Format is Y-M-D-H-M-S - character(len=*), intent(out), optional :: err_msg !< Error message. + character(len=*), optional, intent(out) :: err_msg !< Error message. call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) end subroutine MOM_diag_manager_init @@ -169,224 +166,215 @@ subroutine MOM_diag_manager_end(time) end subroutine MOM_diag_manager_end !> Register a MOM diagnostic field for scalars -integer function register_diag_field_fms_wrapper_scalar(module_name, field_name, init_time, & - & long_name, units, missing_value, range, standard_name, do_not_log, err_msg, & - & area, volume, realm) - character(len=*), intent(in) :: module_name !< The name of the associated module - character(len=*), intent(in) :: field_name !< The name of the field - type(time_type), optional, intent(in) :: init_time !< The registration time. - character(len=*), optional, intent(in) :: long_name !< A long name for the field - character(len=*), optional, intent(in) :: units !< Field metric. - character(len=*), optional, intent(in) :: standard_name !< A standard name for the field - real, optional, intent(in) :: missing_value !< Missing value attribute. - real, dimension(2), optional, intent(in) :: range !< A valid range of the field - logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged - character(len=*), optional, intent(out):: err_msg !< Log message. - integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute - integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute - character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute - - - register_diag_field_fms_wrapper_scalar = register_diag_field_fms(module_name, field_name, init_time, & - long_name, units, missing_value, range, standard_name, do_not_log, err_msg, & - area, volume, realm) - -end function register_diag_field_fms_wrapper_scalar +integer function register_diag_field_infra_scalar(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, & + err_msg, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field units + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume) + +end function register_diag_field_infra_scalar !> Register a MOM diagnostic field for scalars -integer function register_diag_field_fms_wrapper_array(module_name, field_name, axes, init_time, & - & long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & - & err_msg, interp_method, tile_count, & - & area, volume, realm) - character(len=*), intent(in) :: module_name !< The name of the associated module - character(len=*), intent(in) :: field_name !< The name of the field - integer, INTENT(in) :: axes(:) !< Diagnostic ID of 1 dimensional axis attributes for the field. - type(time_type), optional, intent(in) :: init_time !< The registration time. - character(len=*), optional, intent(in) :: long_name !< A long name for the field - character(len=*), optional, intent(in) :: units !< Field metric. - real, optional, intent(in) :: missing_value !< Missing value attribute. - real, dimension(2), optional, intent(in) :: range !< A valid range of the field - logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time. - character(len=*), optional, intent(in) :: standard_name !< A standard name for the field - logical, optional, intent(in) :: verbose !< If true, provide additional log information - logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged - character(len=*), optional, intent(in) :: interp_method !< Not documented - integer, optional, intent(in) :: tile_count !< The tile number for the current PE - character(len=*), optional, intent(out):: err_msg !< Log message. - integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute - integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute - character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute - - - register_diag_field_fms_wrapper_array = register_diag_field_fms(module_name, field_name, axes, init_time, & - & long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & - & err_msg, interp_method, tile_count, & - & area, volume, realm) - -end function register_diag_field_fms_wrapper_array - - -integer function register_static_field_fms_wrapper(module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, do_not_log, interp_method,& - & tile_count, area, volume, realm) - character(len=*), intent(in) :: module_name !< The name of the associated module - character(len=*), intent(in) :: field_name !< The name of the field - integer, INTENT(in) :: axes(:) !< Diagnostic ID of 1 dimensional axis attributes for the field. - character(len=*), optional, intent(in) :: long_name !< A long name for the field - character(len=*), optional, intent(in) :: units !< Field metric. - real, optional, intent(in) :: missing_value !< Missing value attribute. - real, dimension(2), optional, intent(in) :: range !< A valid range of the field - logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time. - character(len=*), optional, intent(in) :: standard_name !< A standard name for the field - logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged - character(len=*), optional, intent(in) :: interp_method !< Not documented - integer, optional, intent(in) :: tile_count !< The tile number for the current PE - integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute - integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute - character(len=*), optional, intent(in):: realm !< String to set as the value to the modeling_realm attribute - - - register_static_field_fms_wrapper = register_static_field_fms(module_name, field_name, axes, long_name, units,& +integer function register_diag_field_infra_array(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, & + do_not_log, err_msg, interp_method, tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_array = register_diag_field_fms(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & + err_msg, interp_method, tile_count, area, volume) + +end function register_diag_field_infra_array + + +integer function register_static_field_infra(module_name, field_name, axes, long_name, units, & + missing_value, range, mask_variant, standard_name, do_not_log, interp_method, & + tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & - interp_method=interp_method,tile_count=tile_count, area=area, volume=volume, realm=realm) -end function register_static_field_fms_wrapper + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) +end function register_static_field_infra !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_0d(diag_field_id, field, time, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real, intent(in) :: field !< Floating point value being recorded - TYPE(time_type), intent(in), optional :: time !< Time slice for this record - CHARACTER(len=*), intent(out), optional :: err_msg !< An optional error message +logical function send_data_infra_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, intent(in) :: field !< The value being recorded + TYPE(time_type), optional, intent(in) :: time !< The time for the current record + CHARACTER(len=*), optional, intent(out) :: err_msg !< An optional error message - send_data_fms_wrapper_0d= send_data_fms(diag_field_id, field, time, err_msg) -end function send_data_fms_wrapper_0d + send_data_infra_0d = send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_infra_0d !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real, dimension(:), intent(in) :: field !< A rank 1 array of floating point values being recorded - type (time_type), intent(in), optional :: time !< The time for the current record. - logical, intent(in), dimension(:), optional :: mask !< An optional rank 1 logical mask. - real, intent(in), dimension(:), optional :: rmask !< An optional rank 1 mask array - integer, intent(in), optional :: is_in !< An optional starting index for subsetting the data being recorded. - integer, intent(in), optional :: ie_in !< An optional end index for subsetting the data being recorded. - real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record - !! in the case where data a data reduction in time is being performed. - character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon - !! returning to the calling routine. - - send_data_fms_wrapper_1d= send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) - -end function send_data_fms_wrapper_1d +logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:), intent(in) :: field !< A 1-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:), optional, intent(in) :: mask !< An optional rank 1 logical mask + real, dimension(:), optional, intent(in) :: rmask !< An optional rank 1 mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_1d = send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + +end function send_data_infra_1d !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, & - & ie_in, je_in, weight, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real, dimension(:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded - type (time_type), intent(in), optional :: time !< The time for the current record. - logical, intent(in), dimension(:,:), optional :: mask !< An optional rank 1 logical mask. - real, intent(in), dimension(:,:), optional :: rmask !< An optional rank 1 mask array - integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. - integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. - integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. - integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. - real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record - !! in the case where data a data reduction in time is being performed. - character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon - !! returning to the calling routine. - - send_data_fms_wrapper_2d= send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & +logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & rmask, ie_in, je_in, weight, err_msg) -end function send_data_fms_wrapper_2d +end function send_data_infra_2d -#ifdef OVERLOAD_R8 !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_2d_r8(diag_field_id, field, time, is_in, js_in, mask, rmask, & - & ie_in, je_in, weight, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real(kind=8), dimension(:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded - type (time_type), intent(in), optional :: time !< The time for the current record. - logical, intent(in), dimension(:,:), optional :: mask !< An optional rank 1 logical mask. - real, intent(in), dimension(:,:), optional :: rmask !< An optional rank 1 mask array - integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. - integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. - integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. - integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. - real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record - !! in the case where data a data reduction in time is being performed. - character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon - !! returning to the calling routine. - - send_data_fms_wrapper_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & - rmask, ie_in, je_in, weight, err_msg) +logical function send_data_infra_3d(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d -end function send_data_fms_wrapper_2d_r8 -#endif +#ifdef OVERLOAD_R8 !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & - & ie_in, je_in, ke_in, weight, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded - type (time_type), intent(in), optional :: time !< The time for the current record. - logical, intent(in), dimension(:,:,:), optional :: mask !< An optional rank 1 logical mask. - real, intent(in), dimension(:,:,:), optional :: rmask !< An optional rank 1 mask array - integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. - integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. - integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. - integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. - integer, intent(in), optional :: ks_in !< An optional k starting index for subsetting the data being recorded. - integer, intent(in), optional :: ke_in !< An optional k end index for subsetting the data being recorded. - real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record - !! in the case where data a data reduction in time is being performed. - character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon - !! returning to the calling routine. - - send_data_fms_wrapper_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & - rmask, ie_in, je_in, ke_in, weight, err_msg) - -end function send_data_fms_wrapper_3d +logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) +end function send_data_infra_2d_r8 -#ifdef OVERLOAD_R8 !> Returns true if the argument data are successfully passed to a diagnostic manager !! with the indicated unique reference id, false otherwise. -logical function send_data_fms_wrapper_3d_r8(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & - & ie_in, je_in, ke_in, weight, err_msg) - integer, intent(in) :: diag_field_id !< A unique identifier for this data to the diagnostic manager - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded - type (time_type), intent(in), optional :: time !< The time for the current record. - logical, intent(in), dimension(:,:,:), optional :: mask !< An optional rank 1 logical mask. - real, intent(in), dimension(:,:,:), optional :: rmask !< An optional rank 1 mask array - integer, intent(in), optional :: is_in !< An optional i starting index for subsetting the data being recorded. - integer, intent(in), optional :: ie_in !< An optional i end index for subsetting the data being recorded. - integer, intent(in), optional :: js_in !< An optional j starting index for subsetting the data being recorded. - integer, intent(in), optional :: je_in !< An optional j end index for subsetting the data being recorded. - integer, intent(in), optional :: ks_in !< An optional k starting index for subsetting the data being recorded. - integer, intent(in), optional :: ke_in !< An optional k end index for subsetting the data being recorded. - real, intent(in), optional :: weight !< An optional scalar weight factor to apply to the current record - !! in the case where data a data reduction in time is being performed. - character(len=*), intent(out), optional :: err_msg !< A log indicating the status of the post upon - !! returning to the calling routine. - - send_data_fms_wrapper_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & +logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & ie_in, je_in, ke_in, weight, err_msg) -end function send_data_fms_wrapper_3d_r8 +end function send_data_infra_3d_r8 #endif !> Add a real scalar attribute to a diagnostic field subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< A unique numeric field id - character(len=*), intent(in) :: att_name !< The name of the attribute - real, intent(in) :: att_value !< A real scalar value + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) @@ -394,9 +382,9 @@ end subroutine MOM_diag_field_add_attribute_scalar_r !> Add an integer attribute to a diagnostic field subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< A unique numeric field id - character(len=*), intent(in) :: att_name !< The name of the attribute - integer, intent(in) :: att_value !< A real scalar value + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< An integer scalar value call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) @@ -404,9 +392,9 @@ end subroutine MOM_diag_field_add_attribute_scalar_i !> Add a character string attribute to a diagnostic field subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< A unique numeric field id - character(len=*), intent(in) :: att_name !< The name of the attribute - character(len=*), intent(in) :: att_value !< A real scalar value + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A character string value call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) @@ -414,9 +402,9 @@ end subroutine MOM_diag_field_add_attribute_scalar_c !> Add a real list of attributes attribute to a diagnostic field subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< A unique numeric field id - character(len=*), intent(in) :: att_name !< The name of the attribute - real, dimension(:), intent(in) :: att_value !< A real scalar value + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< An array of real values call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) @@ -424,14 +412,12 @@ end subroutine MOM_diag_field_add_attribute_r1d !> Add a integer list of attributes attribute to a diagnostic field subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< A unique numeric field id - character(len=*), intent(in) :: att_name !< The name of the attribute - integer, dimension(:), intent(in) :: att_value !< A integer list of values + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< An array of integer values call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d - - end module MOM_diag_manager_infra diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 90496f05a7..b4cce081a0 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -9,11 +9,11 @@ module MOM_diag_mediator use MOM_coms, only : PE_here 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_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end -use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name -use MOM_diag_manager_infra, only : send_data_fms_wrapper, MOM_diag_field_add_attribute, EAST, NORTH -use MOM_diag_manager_infra, only : register_diag_field_fms_wrapper, register_static_field_fms_wrapper -use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end +use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name +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_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 @@ -1271,9 +1271,9 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) if (diag_cs%diag_as_chksum) then call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) elseif (is_stat) then - used = send_data_fms_wrapper(diag%fms_diag_id, locfield) + used = send_data_infra(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end) + used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end) endif diag => diag%next enddo @@ -1323,9 +1323,9 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) if (diag_cs%diag_as_chksum) then call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) elseif (is_stat) then - used = send_data_fms_wrapper(diag%fms_diag_id, locfield) + used = send_data_infra(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int) + used = send_data_infra(diag%fms_diag_id, locfield, time=diag_cs%time_end, weight=diag_cs%time_int) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) @@ -1479,26 +1479,26 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then call assert(size(locfield) == size(locmask), & 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) + ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) else - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=locmask) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) else - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) endif endif endif @@ -1767,26 +1767,26 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then call assert(size(locfield) == size(locmask), & 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) + ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) else - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=locmask) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) else - used = send_data_fms_wrapper(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) endif endif endif @@ -1842,16 +1842,15 @@ subroutine post_xy_average(diag_cs, diag, field) diag_cs%diag_remap_cs(coord)%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - field, & - averaged_field, averaged_mask) + field, averaged_field, averaged_mask) endif if (diag_cs%diag_as_chksum) then call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', & logunit=diag_CS%chksum_iounit) else - used = send_data_fms_wrapper(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, & - weight=diag_cs%time_int, mask=averaged_mask) + used = send_data_infra(diag%fms_xyave_diag_id, averaged_field, & + time=diag_cs%time_end, weight=diag_cs%time_int, mask=averaged_mask) endif end subroutine post_xy_average @@ -2391,13 +2390,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, ! If interp_method is provided we must use it if (area_id>0) then if (volume_id>0) then - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id) else - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2405,13 +2404,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, endif else if (volume_id>0) then - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count, volume=volume_id) else - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2422,13 +2421,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, ! If interp_method is not provided and the field is not at an h-point then interp_method='none' if (area_id>0) then if (volume_id>0) then - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method='none', tile_count=tile_count, area=area_id, volume=volume_id) else - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2436,13 +2435,13 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, endif else if (volume_id>0) then - fms_id = register_diag_field_fms_Wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method='none', tile_count=tile_count, volume=volume_id) else - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2703,10 +2702,10 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & fms_id = diag_cs%num_chksum_diags + 1 diag_cs%num_chksum_diags = fms_id else - fms_id = register_diag_field_fms_wrapper(module_name, field_name, init_time, & - long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, standard_name=standard_name, do_not_log=do_not_log, & - err_msg=err_msg) + fms_id = register_diag_field_infra(module_name, field_name, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, & + err_msg=err_msg) endif if (fms_id /= DIAG_FIELD_NOT_FOUND) then @@ -2734,10 +2733,10 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name - fms_id = register_diag_field_fms_wrapper(module_name, cmor_field_name, init_time, & - long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, & - standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg) + fms_id = register_diag_field_infra(module_name, cmor_field_name, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg) if (fms_id /= DIAG_FIELD_NOT_FOUND) then if (dm_id == -1) then dm_id = get_new_diag_id(diag_cs) @@ -2817,7 +2816,7 @@ function register_static_field(module_name, field_name, axes, & fms_id = diag_cs%num_chksum_diags + 1 diag_cs%num_chksum_diags = fms_id else - fms_id = register_static_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & do_not_log=do_not_log, & @@ -2869,11 +2868,11 @@ function register_static_field(module_name, field_name, axes, & if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name - fms_id = register_static_field_fms_wrapper(module_name, cmor_field_name, & - axes%handles, long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & - standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & - interp_method=interp_method, tile_count=tile_count, area=area) + fms_id = register_static_field_infra(module_name, cmor_field_name, axes%handles, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) if (fms_id /= DIAG_FIELD_NOT_FOUND) then if (dm_id == -1) then dm_id = get_new_diag_id(diag_cs) @@ -4303,31 +4302,18 @@ end subroutine downsample_mask_3d !> Fakes a register of a diagnostic to find out if an obsolete !! parameter appears in the diag_table. -logical function found_in_diagtable(diag, varName, newVarName) +logical function found_in_diagtable(diag, varName) type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. character(len=*), intent(in) :: varName !< The obsolete diagnostic name - character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic ! Local integer :: handle ! Integer handle returned from diag_manager ! We use register_static_field_fms() instead of register_static_field() so ! that the diagnostic does not appear in the available diagnostics list. - handle = register_static_field_fms_wrapper('ocean_model', varName, & - diag%axesT1%handles, 'Obsolete parameter', 'N/A') + handle = register_static_field_infra('ocean_model', varName, diag%axesT1%handles) found_in_diagtable = (handle>0) - if (handle>0 .and. is_root_pe()) then - if (present(newVarName)) then - call MOM_error(WARNING, 'MOM_obsolete_params: '// & - 'diag_table entry "'//trim(varName)//'" found. Use '// & - '"'//trim(newVarName)//'" instead.' ) - else - call MOM_error(WARNING, 'MOM_obsolete_params: '// & - 'diag_table entry "'//trim(varName)//'" is obsolete.' ) - endif - endif - end function found_in_diagtable end module MOM_diag_mediator diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index dbf4037a35..2a3066dfbd 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -4,10 +4,10 @@ module MOM_IS_diag_mediator ! This file is a part of SIS2. See LICENSE.md for the license. use MOM_coms, only : PE_here -use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_fms_wrapper, MOM_diag_axis_init +use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_infra, MOM_diag_axis_init use MOM_diag_manager_infra, only : EAST, NORTH -use MOM_diag_manager_infra, only : register_static_field_fms_wrapper -use MOM_diag_manager_infra, only : register_diag_field_fms_wrapper +use MOM_diag_manager_infra, only : register_static_field_infra +use MOM_diag_manager_infra, only : register_diag_field_infra use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -25,7 +25,7 @@ module MOM_IS_diag_mediator public enable_averages public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid public MOM_IS_diag_mediator_close_registration, get_diag_time_end -public MOM_diag_axis_init, register_static_field_fms_wrapper +public MOM_diag_axis_init, register_static_field_infra !> 2D/3D axes type to contain 1D axes handles and pointers to masks type, public :: axesType @@ -289,48 +289,48 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) if (is_stat) then if (present(mask)) then - used = send_data_fms_wrapper(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, mask=mask) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, mask=mask) elseif(i_data .and. associated(diag%mask2d)) then ! used = send_data(fms_diag_id, locfield, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d) - used = send_data_fms_wrapper(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then ! used = send_data(fms_diag_id, locfield, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%mask2d_comp) - used = send_data_fms_wrapper(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d_comp) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) else - used = send_data_fms_wrapper(fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (present(mask)) then - used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, mask=mask) -! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & -! weight=diag_cs%time_int) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, mask=mask) +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int) elseif(i_data .and. associated(diag%mask2d)) then -! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & -! weight=diag_cs%time_int, rmask=diag%mask2d) - used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then -! used = send_data(fms_diag_id, locfield, diag_cs%time_end, & -! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & -! weight=diag_cs%time_int, rmask=diag%mask2d_comp) - used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d_comp) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) else - used = send_data_fms_wrapper(fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) endif endif @@ -453,7 +453,7 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & diag_cs => axes%diag_cs primary_id = -1 - fms_id = register_diag_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -542,7 +542,7 @@ integer function register_MOM_IS_static_field(module_name, field_name, axes, & diag_cs => axes%diag_cs primary_id = -1 - fms_id = register_static_field_fms_wrapper(module_name, field_name, axes%handles, & + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & do_not_log=do_not_log, & From a1bf2e3dcaaf8ba1bfcce83aebb3ced18aa613d7 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 5 Feb 2021 16:49:37 -0500 Subject: [PATCH 199/212] initialize field-specific vertical extent for target data in fixed sponge case --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index aa224dba41..fe6072681c 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -666,6 +666,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) endif ! stores the reference profile + CS%Ref_val(CS%fldno)%nz_data = CS%nz_data allocate(CS%Ref_val(CS%fldno)%p(CS%nz_data,CS%num_col)) CS%Ref_val(CS%fldno)%p(:,:) = 0.0 do col=1,CS%num_col From 3e75098e4f06d03b5dcc23a24906fffae42bf9f7 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 5 Feb 2021 17:31:29 -0500 Subject: [PATCH 200/212] revert default name for sponge inverse damping timescale and prevent logging of sponge_uv_state file if not used --- src/initialization/MOM_state_initialization.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b54d9702a6..3e745dcafd 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1785,9 +1785,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, param_f call get_param(param_file, mdl, "SPONGE_STATE_FILE", state_file, & "The name of the file with the state to damp toward.", & default=damping_file) - call get_param(param_file, mdl, "SPONGE_UV_STATE_FILE", state_uv_file, & - "The name of the file with the state to damp UV toward.", & - default=damping_file) call get_param(param_file, mdl, "SPONGE_PTEMP_VAR", potemp_var, & "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="PTEMP") @@ -1798,6 +1795,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, param_f "Apply sponges in u and v, in addition to tracers.", & default=.false.) if (sponge_uv) then + call get_param(param_file, mdl, "SPONGE_UV_STATE_FILE", state_uv_file, & + "The name of the file with the state to damp UV toward.", & + default=damping_file) call get_param(param_file, mdl, "SPONGE_U_VAR", u_var, & "The name of the zonal velocity variable in "//& "SPONGE_UV_STATE_FILE.", default="UVEL") @@ -1810,7 +1810,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, param_f "SPONGE_STATE_FILE.", default="ETA") call get_param(param_file, mdl, "SPONGE_IDAMP_VAR", Idamp_var, & "The name of the inverse damping rate variable in "//& - "SPONGE_DAMPING_FILE.", default="IDAMP") + "SPONGE_DAMPING_FILE.", default="Idamp") if (sponge_uv) then call get_param(param_file, mdl, "SPONGE_UV_DAMPING_FILE", uv_damping_file, & "The name of the file with sponge damping rates for the velocity variables.", & From 770197b6205bc981978525725d57f4b38bd7c1c8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Feb 2021 06:56:06 -0500 Subject: [PATCH 201/212] +(*)Restore ability to use decomposed restart files Added optional MOM_Domain arguments to the 0-d and 1-d versions of MOM_read_data, enabling them to read from a domain-decomposed file if the single file is not present. The MOM_read_data calls in restore_state were modified to use these new optional arguments, thereby restoring the ability of MOM6 to read from domain-decomposed restart files, which had been broken by a known miscreant on January 3, 2021 with MOM6 commit aea16f73. All answers and output are bitwise identical in cases that worked. --- src/framework/MOM_io_infra.F90 | 28 ++++++++++++++++++++-------- src/framework/MOM_restart.F90 | 6 ++++-- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index 8ae45e4903..978ca71c8a 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -315,17 +315,23 @@ subroutine get_axis_data( axis, dat ) call mpp_get_axis_data( axis, dat ) end subroutine get_axis_data -!> This routine uses the fms_io subroutine read_data to read a scalar -!! data field named "fieldname" from file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale) +!> This routine uses the fms_io subroutine read_data to read a scalar named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain) 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, intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + if (present(MOM_Domain)) then + 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 data = scale*data @@ -333,17 +339,23 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale) end subroutine MOM_read_data_0d -!> This routine uses the fms_io subroutine read_data to read a 1-D -!! data field named "fieldname" from file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) +!> This routine uses the fms_io subroutine read_data to read a 1-D data field named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain) 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 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before they are returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + if (present(MOM_Domain)) then + 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 data(:) = scale*data(:) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d0b3b24aef..29500875ca 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1202,10 +1202,12 @@ subroutine restore_state(filename, directory, day, G, CS) if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. - call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, timelevel=1) + call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & + timelevel=1, MOM_Domain=G%Domain) if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... - call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, timelevel=1) + call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & + timelevel=1, MOM_Domain=G%Domain) if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. if (pos /= 0) then From 9a315f2547f7daa9fda11130be1a6125326e308e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Feb 2021 19:47:31 -0500 Subject: [PATCH 202/212] Included array_global_min_man in MOM_generic_tracer.F90 Included a copy of mpp_array_global_min_man from mpp_utilities in MOM_generic_tracer.F90 as array_global_min_max to document what had been an interface from mpp that is used in MOM6, and to break a dependence on a part of the FMS code. There are a number of serious problems with this routine, both with it reporting values that are incorrect and with it failing most forms of self-consistency testing. But rather than fixing any of these problems, they are noted in comments, and this is an exact reproduction of its predecessor. --- src/tracer/MOM_generic_tracer.F90 | 137 ++++++++++++++++++++++++++++-- 1 file changed, 132 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 650e66c47f..9f39237211 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -28,6 +28,8 @@ module MOM_generic_tracer 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 MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS + use MOM_coms, only : max_across_PEs, min_across_PEs, PE_here use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -36,10 +38,10 @@ module MOM_generic_tracer 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 + use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_spatial_means, only : global_area_mean use MOM_sponge, only : set_up_sponge_field, sponge_CS - use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -47,7 +49,6 @@ module MOM_generic_tracer use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs - use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type @@ -633,7 +634,6 @@ end function MOM_generic_tracer_stock !! requested specifically, returning the number of tracers it has gone through. function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & xgmax, ygmax, zgmax , G, CS, names, units) - use mpp_utilities_mod, only: mpp_array_global_min_max integer, intent(in) :: ind_start !< The index of the tracer to start with logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and !! max are found for each tracer @@ -693,8 +693,8 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg tr_ptr => tr_field(:,:,:,1) - call mpp_array_global_min_max(tr_ptr, grid_tmask,isd,jsd,isc,iec,jsc,jec,nk , gmin(m), gmax(m), & - G%geoLonT,G%geoLatT,geo_z,xgmin(m), ygmin(m), zgmin(m), & + call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & + G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & xgmax(m), ygmax(m), zgmax(m)) got_minmax(m) = .true. @@ -710,6 +710,133 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg end function MOM_generic_tracer_min_max + !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. + subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & + geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) + integer, intent(in) :: isd !< The starting data domain i-index + integer, intent(in) :: jsd !< The starting data domain j-index + real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema + real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude + integer, intent(in) :: isc !< The starting compute domain i-index + integer, intent(in) :: iec !< The ending compute domain i-index + integer, intent(in) :: jsc !< The starting compute domain j-index + integer, intent(in) :: jec !< The ending compute domain j-index + integer, intent(in) :: nk !< The number of vertical levels + real, intent(out) :: g_min !< The global minimum of tr_array + real, intent(out) :: g_max !< The global maximum of tr_array + real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points + real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points + real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points + real, intent(out) :: xgmin !< The x-position of the global minimum + real, intent(out) :: ygmin !< The y-position of the global minimum + real, intent(out) :: zgmin !< The z-position of the global minimum + real, intent(out) :: xgmax !< The x-position of the global maximum + real, intent(out) :: ygmax !< The y-position of the global maximum + real, intent(out) :: zgmax !< The z-position of the global maximum + + ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() + ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match + ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with + ! added comments to document its arguments.i + + !### The obvious problems with this routine as currently written include: + ! 1. It does not return exactly the maximum and minimum values. + ! 2. The reported maximum and minimum are dependent on PE count and layout. + ! 3. For all-zero arrays, the reported maxima scale with the PE_count + ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed + ! 1e10, the values it returns are simply wrong. + ! 5. The results do not scale appropriately if the argument is rescaled. + ! 6. The extrema and locations are not rotationally invariant. + ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. + + ! Local variables + 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 + integer :: igmax, jgmax, kgmax, igmin, jgmin, kgmin + real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema. + + ! arrays to enable vectorization + integer :: iminarr(3), imaxarr(3) + + !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. + g_min = -88888888888.0 ; g_max = -999999999.0 + tmax = -1.e10 ; tmin = 1.e10 + itmax = 0 ; jtmax = 0 ; ktmax = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 + + if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then + ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. + iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) + imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) + itmin = iminarr(1)+isc-1 + jtmin = iminarr(2)+jsc-1 + ktmin = iminarr(3) + itmax = imaxarr(1)+isc-1 + jtmax = imaxarr(2)+jsc-1 + ktmax = imaxarr(3) + tmin = tr_array(itmin,jtmin,ktmin) + tmax = tr_array(itmax,jtmax,ktmax) + end if + + ! use "fudge" to distinguish processors when tracer extreme is independent of processor + !### This fudge factor is not independent of PE layout, and while it mostly works for finding + ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite + ! cases, for which the fudge factor should be slightly reduced. The fudge factor should + ! be based on global index-space conventions, which are decomposition invariant, and + ! not the PE-number! + fudge = 1.0 + 1.e-12*real(PE_here() ) + tmax = tmax*fudge + tmin = tmin*fudge + if (tmax == 0.0) then + tmax = tmax + 1.e-12*real(PE_here() ) + endif + if (tmin == 0.0) then + tmin = tmin + 1.e-12*real(PE_here() ) + endif + + tmax0 = tmax ; tmin0 = tmin + + call max_across_PEs(tmax) + call min_across_PEs(tmin) + + g_max = tmax + g_min = tmin + + ! Now find the location of the global extrema. + ! + ! Note that the fudge factor above guarantees that the location of max (min) is uinque, + ! 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. + ! + !-999 on all current PE's + xgmax = -999. ; ygmax = -999. ; zgmax = -999. + xgmin = -999. ; ygmin = -999. ; zgmin = -999. + + if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. + xgmax = geo_x(itmax,jtmax) + ygmax = geo_y(itmax,jtmax) + zgmax = geo_z(ktmax) + endif + + !### These three calls and the three calls that follow in about 10 lines should be combined + ! into a single call for efficiency. + call max_across_PEs(xgmax) + call max_across_PEs(ygmax) + call max_across_PEs(zgmax) + + if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. + xgmin = geo_x(itmin,jtmin) + ygmin = geo_y(itmin,jtmin) + zgmin = geo_z(ktmin) + endif + + call max_across_PEs(xgmin) + call max_across_PEs(ygmin) + call max_across_PEs(zgmin) + + end subroutine array_global_min_max !> This subroutine calculates the surface state and sets coupler values for !! those generic tracers that have flux exchange with atmosphere. From 3a050fb5ebab5510f9931691b1db07b90bf54efa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Feb 2021 20:30:40 -0500 Subject: [PATCH 203/212] Cleaned up framework argument documentation Modified some of the framework argument declarations to follow the usual pattern for the declaration of optional arguments in MOM6 code, and corrected or clarified a number of the comments describing the arguments or interfaces. All answers are bitwise identical. --- src/framework/MOM_coms_infra.F90 | 121 ++++++++++--------- src/framework/MOM_cpu_clock_infra.F90 | 4 +- src/framework/MOM_ensemble_manager_infra.F90 | 33 +++-- src/framework/MOM_time_manager.F90 | 18 +-- 4 files changed, 89 insertions(+), 87 deletions(-) diff --git a/src/framework/MOM_coms_infra.F90 b/src/framework/MOM_coms_infra.F90 index 6ead560537..555b4df119 100644 --- a/src/framework/MOM_coms_infra.F90 +++ b/src/framework/MOM_coms_infra.F90 @@ -93,16 +93,16 @@ subroutine set_rootPE(pe) !! is set to the list of all available PEs on the communicator. Setting the !! list will trigger a rank synchronization unless the `no_sync` flag is set. subroutine Set_PEList(pelist, no_sync) - integer, intent(in), optional :: pelist(:) !< List of - logical, intent(in), optional :: no_sync !< Do not sync after list update. + integer, optional, intent(in) :: pelist(:) !< List of PEs to set for communication + logical, optional, intent(in) :: no_sync !< Do not sync after list update. call mpp_set_current_pelist(pelist, no_sync) end subroutine Set_PEList !> Retrieve the current PE list and any metadata if requested. subroutine Get_PEList(pelist, name, commID) - integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list - character(len=*), intent(out), optional :: name !< Name of PE list - integer, intent(out), optional :: commID !< Communicator ID of PE list + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), optional, intent(out) :: name !< Name of PE list + integer, optional, intent(out) :: commID !< Communicator ID of PE list call mpp_get_current_pelist(pelist, name, commiD) end subroutine Get_PEList @@ -311,134 +311,137 @@ end function field_chksum_real_4d ! sum_across_PEs wrappers -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of field across PEs, and return this sum in field. subroutine sum_across_PEs_int4_0d(field, pelist) - integer(kind=int32), intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + integer(kind=int32), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_sum(field, pelist) end subroutine sum_across_PEs_int4_0d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. subroutine sum_across_PEs_int4_1d(field, length, pelist) - integer(kind=int32), dimension(:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + 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_1d -!> Find the sum of field across PEs, and update PEs with the sums. +!> 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 !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_sum(field, pelist) end subroutine sum_across_PEs_int8_0d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. subroutine sum_across_PEs_int8_1d(field, length, pelist) - integer(kind=int64), dimension(:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + integer(kind=int64), 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_int8_1d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. subroutine sum_across_PEs_int8_2d(field, length, pelist) - integer(kind=int64), dimension(:,:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + integer(kind=int64), & + dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_sum(field, length, pelist) end subroutine sum_across_PEs_int8_2d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of field across PEs, and return this sum in field. subroutine sum_across_PEs_real_0d(field, pelist) - real, intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + real, intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_sum(field, pelist) end subroutine sum_across_PEs_real_0d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. subroutine sum_across_PEs_real_1d(field, length, pelist) - real, dimension(:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + real, 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_real_1d -!> Find the sum of field across PEs, and update PEs with the sums. +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. subroutine sum_across_PEs_real_2d(field, length, pelist) - real, dimension(:,:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + real, dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_sum(field, length, pelist) end subroutine sum_across_PEs_real_2d ! max_across_PEs wrappers -!> Find the maximum value of field across PEs, and update PEs with the values. +!> Find the maximum value of field across PEs, and store this maximum in field. subroutine max_across_PEs_int_0d(field, pelist) - integer, intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + integer, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_max(field, pelist) end subroutine max_across_PEs_int_0d -!> Find the maximum value of field across PEs, and update PEs with the values. +!> Find the maximum value of field across PEs, and store this maximum in field. subroutine max_across_PEs_real_0d(field, pelist) - real, intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + real, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_max(field, pelist) end subroutine max_across_PEs_real_0d -!> Find the maximum value of field across PEs, and update PEs with the values. +!> Find the maximum values in each position of field across PEs, and store these minima in field. subroutine max_across_PEs_real_1d(field, length, pelist) - real, dimension(:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! maxima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_max(field, length, pelist) end subroutine max_across_PEs_real_1d ! min_across_PEs wrappers -!> Find the minimum value of field across PEs, and update PEs with the values. +!> Find the minimum value of field across PEs, and store this minimum in field. subroutine min_across_PEs_int_0d(field, pelist) - integer, intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list + integer, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_min(field, pelist) end subroutine min_across_PEs_int_0d -!> Find the minimum value of field across PEs, and update PEs with the values. +!> Find the minimum value of field across PEs, and store this minimum in field. subroutine min_across_PEs_real_0d(field, pelist) - real, intent(inout) :: field !< Input field - integer, intent(in), optional :: pelist(:) !< PE list - + real, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_min(field, pelist) end subroutine min_across_PEs_real_0d -!> Find the minimum value of field across PEs, and update PEs with the values. +!> Find the minimum values in each position of field across PEs, and store these minima in field. subroutine min_across_PEs_real_1d(field, length, pelist) - real, dimension(:), intent(inout) :: field !< Input field - integer, intent(in) :: length !< Length of field - integer, intent(in), optional :: pelist(:) !< PE list + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! minima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d -!> Initialize the model framework, including PE communication over a designated -!! communicator. If no communicator ID is provided, then the framework's -!! default communicator is used. +!> Initialize the model framework, including PE communication over a designated communicator. +!! If no communicator ID is provided, the framework's default communicator is used. subroutine MOM_infra_init(localcomm) - integer, intent(in), optional :: localcomm !< Communicator ID to initialize + integer, optional, intent(in) :: localcomm !< Communicator ID to initialize call fms_init(localcomm) end subroutine diff --git a/src/framework/MOM_cpu_clock_infra.F90 b/src/framework/MOM_cpu_clock_infra.F90 index f0a4a71ae5..47d7bbedaa 100644 --- a/src/framework/MOM_cpu_clock_infra.F90 +++ b/src/framework/MOM_cpu_clock_infra.F90 @@ -73,13 +73,13 @@ end subroutine cpu_clock_end !> Returns the integer handle for a named CPU clock. integer function cpu_clock_id( name, synchro_flag, grain ) character(len=*), intent(in) :: name !< The unique name of the CPU clock - integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs + integer, optional, intent(in) :: synchro_flag !< An integer flag that controls whether the PEs !! are synchronized before the cpu clocks start counting. !! Synchronization occurs before the start of a clock if this !! is odd, while additional (expensive) statistics can set !! for other values. If absent, the default is taken from the !! settings for FMS. - integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to + integer, optional, intent(in) :: grain !< The timing granularity for this clock, usually set to !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. if (present(synchro_flag)) then diff --git a/src/framework/MOM_ensemble_manager_infra.F90 b/src/framework/MOM_ensemble_manager_infra.F90 index 314bdc0670..66bbb86e2f 100644 --- a/src/framework/MOM_ensemble_manager_infra.F90 +++ b/src/framework/MOM_ensemble_manager_infra.F90 @@ -30,13 +30,13 @@ end subroutine ensemble_manager_init !! associated with the current ensemble member. subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) - logical, intent(in) :: concurrent !< A logical flag, if True, then - !! ocean fast PEs are run concurrently with - !! slow PEs within the coupler. - integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs - integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs - integer, intent(in) :: land_npes !< The number of land PEs (fast) - integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + logical, intent(in) :: concurrent !< A logical flag, if True, then ocean fast + !! PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs @@ -71,25 +71,24 @@ function get_ensemble_size() end function get_ensemble_size !> Returns the list of PEs associated with all ensemble members -!! Results are stored in the argument array which ust be large +!! Results are stored in the argument array which must be large !! enough to contain the list. If the optional name argument is present, !! the returned processor list are for a particular component (atmos, ocean ,land, ice) subroutine get_ensemble_pelist(pelist, name) - integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members - character(len=*), intent(in), optional :: name !< An optional component name (atmos, ocean, land, ice) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), optional, intent(in) :: name !< An optional component name (atmos, ocean, land, ice) - call FMS_get_ensemble_pelist(pelist,name) + call FMS_get_ensemble_pelist(pelist, name) end subroutine get_ensemble_pelist -!> Returns the list of PEs associated with an ensemble filter application. -!! If the optional name argument is present, the returned list is for a -!! particular component (atmos, ocean ,land, ice) +!> Returns the list of PEs associated with the named ensemble filter application. +!! Valid component names include ('atmos', 'ocean', 'land', and 'ice') subroutine get_ensemble_filter_pelist(pelist, name) - integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter - character(len=*), intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< The component name (atmos, ocean, land, ice) - call FMS_get_Ensemble_filter_pelist(pelist,name) + call FMS_get_Ensemble_filter_pelist(pelist, name) end subroutine get_ensemble_filter_pelist diff --git a/src/framework/MOM_time_manager.F90 b/src/framework/MOM_time_manager.F90 index 0f8ced0928..5f3279b713 100644 --- a/src/framework/MOM_time_manager.F90 +++ b/src/framework/MOM_time_manager.F90 @@ -29,15 +29,15 @@ module MOM_time_manager contains -!> This is an alternate implementation of the FMS function real_to_time_type that is accurate over -!! a larger range of input values. With 32 bit signed integers, this version should work over the -!! entire valid range (2^31 days or ~5.8835 million years) of time_types, whereas the standard -!! version in the FMS time_manager stops working for conversions of times greater than 2^31 seconds, -!! or ~68.1 years. -function real_to_time(x, err_msg) - type(time_type) :: real_to_time !< The output time as a time_type - real, intent(in) :: x !< The input time in real seconds. - character(len=*), intent(out), optional :: err_msg !< An optional returned error message. +!> Returns a time_type version of a real time in seconds, using an alternate implementation to the +!! FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit +!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835 +!! million years) of time_types, whereas the standard version in the FMS time_manager stops working +!! for conversions of times greater than 2^31 seconds, or ~68.1 years. +type(time_type) function real_to_time(x, err_msg) +! type(time_type) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. ! Local variables integer :: seconds, days, ticks From 750fb20e7d2f43564137ccf65c8ae674a4b2c95a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Feb 2021 21:30:10 -0500 Subject: [PATCH 204/212] +Cleaned up MOM_inter_infra argument documentation Modified the MOM_inter_infra argument declarations to follow the usual pattern for the declaration of optional arguments in MOM6 code. Also eliminated an optional argument to horiz_inter_from_weights that was only described as "unknown" always hard-coded to .true. in all calls from the MOM6 code. All answers are bitwise identical, but one optional argument was removed. --- src/framework/MOM_horizontal_regridding.F90 | 6 +- src/framework/MOM_interp_infra.F90 | 86 ++++++++++----------- 2 files changed, 43 insertions(+), 49 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index a4a483711a..8d02dfdf3f 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -539,8 +539,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_ongrid) then tr_out(is:ie,js:je)=tr_in(is:ie,js:je) else - call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), & - missing_value=missing_value, new_missing_handle=.true.) + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) endif mask_out=1.0 @@ -824,8 +823,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t tr_out(:,:) = 0.0 - call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & - new_missing_handle=.true.) + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) mask_out(:,:) = 1.0 do j=js,je ; do i=is,ie diff --git a/src/framework/MOM_interp_infra.F90 b/src/framework/MOM_interp_infra.F90 index c9151b841e..ca5b2b8516 100644 --- a/src/framework/MOM_interp_infra.F90 +++ b/src/framework/MOM_interp_infra.F90 @@ -41,26 +41,23 @@ module MOM_interp_infra !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d -subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit, & - err_msg, new_missing_handle) - - type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation - !! options/weights - real, intent(in), dimension(:,:) :: data_in !< input data - real, intent(out), dimension(:,:) :: data_out !< output data - integer, intent(in), optional :: verbose !< verbosity level - real, intent(in), dimension(:,:), optional :: mask_in !< mask for input data - real, intent(out), dimension(:,:), optional :: mask_out !< mask for output data - real, intent(in), optional :: missing_value !< missing value - integer, intent(in), optional :: missing_permit !< number of allowed points with missing value - !! for interpolation (0-3) - character(len=*), intent(out), optional :: err_msg !< error message - logical, intent(in), optional :: new_missing_handle !< unknown +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: data_in !< input data + real, dimension(:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message call horiz_interp(Interp, data_in, data_out, verbose, & mask_in, mask_out, missing_value, missing_permit, & - err_msg, new_missing_handle ) + err_msg, new_missing_handle=.true. ) end subroutine horiz_interp_from_weights_field2d @@ -70,17 +67,16 @@ end subroutine horiz_interp_from_weights_field2d subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & missing_value, missing_permit, err_msg) - type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation - !! options/weights - real, intent(in), dimension(:,:,:) :: data_in !< input data - real, intent(out), dimension(:,:,:) :: data_out !< output data - integer, intent(in), optional :: verbose !< verbosity level - real, intent(in), dimension(:,:,:), optional :: mask_in !< mask for input data - real, intent(out), dimension(:,:,:), optional :: mask_out !< mask for output data - real, intent(in), optional :: missing_value !< missing value - integer, intent(in), optional :: missing_permit !< number of allowed points with missing value - !! for interpolation (0-3) - character(len=*), intent(out), optional :: err_msg !< error message + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:,:), intent(in) :: data_in !< input data + real, dimension(:,:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & missing_value, missing_permit, err_msg) @@ -95,20 +91,20 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, src_modulo, mask_in, mask_out, & is_latlon_in, is_latlon_out) - type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options/weights - real, intent(in), dimension(:,:) :: lon_in !< input longitude 2d - real, intent(in), dimension(:,:) :: lat_in !< input latitude 2d - real, intent(in), dimension(:,:) :: lon_out !< output longitude 2d - real, intent(in), dimension(:,:) :: lat_out !< output latitude 2d - integer, intent(in), optional :: verbose !< verbosity level - character(len=*), intent(in), optional :: interp_method !< interpolation method - integer, intent(in), optional :: num_nbrs !< number of nearest neighbors - real, intent(in), optional :: max_dist !< maximum region of influence - logical, intent(in), optional :: src_modulo !< periodicity of E-W boundary - real, intent(in), dimension(:,:), optional :: mask_in !< mask for input data - real, intent(inout),dimension(:,:), optional :: mask_out !< mask for output data - logical, intent(in), optional :: is_latlon_in !< input grid is regular lat/lon grid - logical, intent(in), optional :: is_latlon_out !< output grid is regular lat/lon grid + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: lon_in !< input longitude 2d + real, dimension(:,:), intent(in) :: lat_in !< input latitude 2d + real, dimension(:,:), intent(in) :: lon_out !< output longitude 2d + real, dimension(:,:), intent(in) :: lat_out !< output latitude 2d + integer, optional, intent(in) :: verbose !< verbosity level + character(len=*), optional, intent(in) :: interp_method !< interpolation method + integer, optional, intent(in) :: num_nbrs !< number of nearest neighbors + real, optional, intent(in) :: max_dist !< maximum region of influence + logical, optional, intent(in) :: src_modulo !< periodicity of E-W boundary + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(inout) :: mask_out !< mask for output data + logical, optional, intent(in) :: is_latlon_in !< input grid is regular lat/lon grid + logical, optional, intent(in) :: is_latlon_out !< output grid is regular lat/lon grid call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & verbose, interp_method, num_nbrs, max_dist, & @@ -121,7 +117,7 @@ end subroutine build_horiz_interp_weights_2d_to_2d !> get size of an external field from field index function get_extern_field_size(index) - integer :: index !< field index + integer, intent(in) :: index !< field index integer :: get_extern_field_size(4) !< field size get_extern_field_size = get_external_field_size(index) @@ -132,7 +128,7 @@ end function get_extern_field_size !> get axes of an external field from field index function get_extern_field_axes(index) - integer :: index !< field 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) @@ -143,7 +139,7 @@ end function get_extern_field_axes !> get missing value of an external field from field index function get_extern_field_missing(index) - integer :: index !< field index + integer, intent(in) :: index !< field index real :: get_extern_field_missing !< field missing value get_extern_field_missing = get_external_field_missing(index) From feacf1a12da7bcb605cfc663807c515ba5b6c740 Mon Sep 17 00:00:00 2001 From: He Wang Date: Wed, 10 Feb 2021 16:10:35 -0500 Subject: [PATCH 205/212] Correct a horizontal indexing error related to linear wave drag in MOM_barotropic --- src/core/MOM_barotropic.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 06b1e95edc..628f8e1c39 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1462,7 +1462,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i,j+1)) if (GV%Boussinesq) & - Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j+1)) + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1)) bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot From 4c3ef14701c220ba4a3a4314b4600397c18b9235 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 11 Feb 2021 12:39:26 -0500 Subject: [PATCH 206/212] trailer.py PEP8/PEP257 cleanup This patch cleans up the trailer.py tool to conform to the PEP8 and PEP257 Python style guides: https://www.python.org/dev/peps/pep-0008/ https://www.python.org/dev/peps/pep-0257/ Specifically, the `pycodestyle` and `pydocstyle` tools no longer report any nonconformance, and report the script as passing. --- .testing/trailer.py | 199 ++++++++++++++++++++++++++------------------ 1 file changed, 118 insertions(+), 81 deletions(-) diff --git a/.testing/trailer.py b/.testing/trailer.py index a483bf9995..64f016275f 100755 --- a/.testing/trailer.py +++ b/.testing/trailer.py @@ -1,100 +1,137 @@ #!/usr/bin/env python +"""Subroutines for Validating the whitespace of the source code.""" import argparse import os import re import sys + def parseCommandLine(): - """ - Parse the command line positional and optional arguments. - This is the highest level procedure invoked from the very end of the script. - """ + """Parse the command line positional and optional arguments. + + This is the highest level procedure invoked from the very end of the + script. + """ + # Arguments + parser = argparse.ArgumentParser( + description='trailer.py checks Fortran files for trailing white ' + 'space.', + epilog='Written by A.Adcroft, 2017.' + ) + parser.add_argument( + 'files_or_dirs', type=str, nargs='+', + metavar='FILE|DIR', + help='Fortran files or director in which to search for Fortran files ' + '(with .f, .f90, .F90 suffixes).''' + ) + parser.add_argument( + '-e', '--exclude_dir', type=str, action='append', + metavar='DIR', + help='''Exclude directories from search that end in DIR.''' + ) + parser.add_argument( + '-l', '--line_length', type=int, default=512, + help='''Maximum allowed length of a line.''' + ) + parser.add_argument( + '-s', '--source_line_length', type=int, default=132, + help='''Maximum allowed length of a source line excluding comments.''' + ) + parser.add_argument( + '-d', '--debug', action='store_true', + help='turn on debugging information.' + ) + args = parser.parse_args() - # Arguments - parser = argparse.ArgumentParser(description='''trailer.py checks Fortran files for trailing white space.''', - epilog='Written by A.Adcroft, 2017.') - parser.add_argument('files_or_dirs', type=str, nargs='+', - metavar='FILE|DIR', - help='''Fortran files or director in which to search for Fortran files (with .f, .f90, .F90 suffixes).''') - parser.add_argument('-e','--exclude_dir', type=str, action='append', - metavar='DIR', - help='''Exclude directories from search that end in DIR.''') - parser.add_argument('-l','--line_length', type=int, default=512, - help='''Maximum allowed length of a line.''') - parser.add_argument('-s','--source_line_length', type=int, default=132, - help='''Maximum allowed length of a source line excluding comments.''') - parser.add_argument('-d','--debug', action='store_true', - help='turn on debugging information.') - args = parser.parse_args() + global debug + debug = args.debug - global debug - debug = args.debug + main(args) - main(args) def main(args): - ''' - Does the actual work - ''' - if (debug): print(args) + """Do the actual work.""" + if (debug): + print(args) - # Process files_or_dirs argument into list of files - all_files = [] - for a in args.files_or_dirs: - if os.path.isfile(a): all_files.append(a) - elif os.path.isdir(a): - for d,s,files in os.walk(a): - ignore = False - if args.exclude_dir is not None: - for e in args.exclude_dir: - if e+'/' in d+'/': ignore = True - if not ignore: - for f in files: - _,ext = os.path.splitext(f) - if ext in ('.f','.F','.f90','.F90'): all_files.append( os.path.join(d,f) ) - else: raise Exception('Argument '+a+' is not a file or directory! Stopping.') - if (debug): print('Found: ',all_files) + # Process files_or_dirs argument into list of files + all_files = [] + for a in args.files_or_dirs: + if os.path.isfile(a): + all_files.append(a) + elif os.path.isdir(a): + for d, s, files in os.walk(a): + ignore = False + if args.exclude_dir is not None: + for e in args.exclude_dir: + if e+'/' in d+'/': + ignore = True + if not ignore: + for f in files: + _, ext = os.path.splitext(f) + if ext in ('.f', '.F', '.f90', '.F90'): + all_files.append(os.path.join(d, f)) + else: + raise Exception('Argument '+a+' is not a file or directory! ' + 'Stopping.') + if (debug): + print('Found: ', all_files) + + # For each file, check for trailing white space + fail = False + for filename in all_files: + this = scan_file(filename, line_length=args.line_length, + source_line_length=args.source_line_length) + fail = fail or this + if fail: + sys.exit(1) - # For each file, check for trailing white space - fail = False - for filename in all_files: - this = scan_file(filename, line_length=args.line_length, source_line_length=args.source_line_length) - fail = fail or this - if fail: sys.exit(1) def scan_file(filename, line_length=512, source_line_length=132): - '''Scans file for trailing white space''' - def msg(filename,lineno,mesg,line=None): - if line is None: print('%s, line %i: %s'%(filename,lineno,mesg)) - else: print('%s, line %i: %s "%s"'%(filename,lineno,mesg,line)) - white_space_detected = False - tabs_space_detected = False - long_line_detected = False - with open(filename) as file: - trailing_space = re.compile(r'.* +$') - tabs = re.compile(r'.*\t.*') - lineno = 0 - for line in file.readlines(): - lineno += 1 - line = line.replace('\n','') - srcline = line.split('!', 1)[0] # Discard comments - if trailing_space.match(line) is not None: - if debug: print(filename,lineno,line,trailing_space.match(line)) - if len(line.strip())>0: msg(filename,lineno,'Trailing space detected',line) - else: msg(filename,lineno,'Blank line contains spaces') - white_space_detected = True - if tabs.match(line) is not None: - if len(line.strip())>0: msg(filename,lineno,'Tab detected',line) - else: msg(filename,lineno,'Blank line contains tabs') - tabs_space_detected = True - if len(line)>line_length: - if len(line.strip())>0: msg(filename,lineno,'Line length exceeded',line) - else: msg(filename,lineno,'Blank line exceeds line length limit') - long_line_detected = True - if len(srcline)>source_line_length: - msg(filename,lineno,'Non-comment line length exceeded',line) - return white_space_detected or tabs_space_detected or long_line_detected + """Scan file for trailing white space.""" + def msg(filename, lineno, mesg, line=None): + if line is None: + print('%s, line %i: %s' % (filename, lineno, mesg)) + else: + print('%s, line %i: %s "%s"' % (filename, lineno, mesg, line)) + white_space_detected = False + tabs_space_detected = False + long_line_detected = False + with open(filename) as file: + trailing_space = re.compile(r'.* +$') + tabs = re.compile(r'.*\t.*') + lineno = 0 + for line in file.readlines(): + lineno += 1 + line = line.replace('\n', '') + srcline = line.split('!', 1)[0] # Discard comments + if trailing_space.match(line) is not None: + if debug: + print(filename, lineno, line, trailing_space.match(line)) + if len(line.strip()) > 0: + msg(filename, lineno, 'Trailing space detected', line) + else: + msg(filename, lineno, 'Blank line contains spaces') + white_space_detected = True + if tabs.match(line) is not None: + if len(line.strip()) > 0: + msg(filename, lineno, 'Tab detected', line) + else: + msg(filename, lineno, 'Blank line contains tabs') + tabs_space_detected = True + if len(line) > line_length: + if len(line.strip()) > 0: + msg(filename, lineno, 'Line length exceeded', line) + else: + msg(filename, lineno, + 'Blank line exceeds line length limit') + long_line_detected = True + if len(srcline) > source_line_length: + msg(filename, lineno, 'Non-comment line length exceeded', line) + return white_space_detected or tabs_space_detected or long_line_detected + # Invoke parseCommandLine(), the top-level procedure -if __name__ == '__main__': parseCommandLine() +if __name__ == '__main__': + parseCommandLine() From 27cd1c44f3fdd6443ee9dec2d067d6c883e83d59 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Feb 2021 05:57:29 -0500 Subject: [PATCH 207/212] +Added open_ASCII_file Added the new subroutine open_ASCII_file to open text files that can be read or written to using simple Fortran read or write statements. This was previously handled via a common open_file call, but FMS2 is changing the interface for this routine, and creating this new file de-conflicts most the MOM6 calls to open_file from these altered interfaces. The existing routine open_file is unaltered and works exactly as before. A number of existing calls to open_file were also modified to use this new interface, in some cases where only the root_PE was writing, this includes altering the code so that only the root_PE actually opens the file. All answers and output are bitwise identical. --- .../ice_solo_driver/ice_shelf_driver.F90 | 42 +++++++++--------- config_src/solo_driver/MOM_driver.F90 | 44 +++++++++---------- src/diagnostics/MOM_PointAccel.F90 | 11 +++-- src/diagnostics/MOM_sum_output.F90 | 10 ++--- src/framework/MOM_io.F90 | 10 ++--- src/framework/MOM_io_infra.F90 | 27 ++++++++++-- src/framework/MOM_write_cputime.F90 | 14 +++--- 7 files changed, 84 insertions(+), 74 deletions(-) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index b1323a5485..bd64050a6f 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -38,9 +38,9 @@ program Shelf_main use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_hor_index, only : hor_index_type, hor_index_init - use MOM_io, only : MOM_io_init, file_exists, open_file, close_file + use MOM_io, only : MOM_io_init, 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, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_io, only : APPEND_FILE, READONLY_FILE, SINGLE_FILE use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : save_restart use MOM_string_functions,only : uppercase @@ -176,7 +176,7 @@ program Shelf_main if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. - call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) + call open_ASCII_file(unit, 'input.nml', action=READONLY_FILE) read(unit, ice_solo_nml, iostat=io_status) call close_file(unit) ierr = check_nml_error(io_status,'ice_solo_nml') @@ -187,15 +187,14 @@ program Shelf_main ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ice_solo.res')) then - call open_file(unit,trim(dirs%restart_input_dir)//'ice_solo.res', & - form=ASCII_FILE,action=READONLY_FILE) + call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ice_solo.res', action=READONLY_FILE) read(unit,*) calendar_type read(unit,*) date_init read(unit,*) date call close_file(unit) else calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN + if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS @@ -341,15 +340,14 @@ program Shelf_main call diag_mediator_close_registration(diag) ! Write out a time stamp file. - if (calendar_type /= NO_CALENDAR) then - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) + if (is_root_pe() .and. (calendar_type /= NO_CALENDAR)) then + call open_ASCII_file(unit, 'time_stamp.out', action=APPEND_FILE) call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + write(unit,'(6i4,2x,a3)') date, month(1:3) call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + write(unit,'(6i4,2x,a3)') date, month(1:3) call close_file(unit) endif @@ -428,19 +426,19 @@ program Shelf_main dirs%restart_output_dir) ! Write ice shelf solo restart file. - call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) if (is_root_pe())then - 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 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 - call close_file(unit) endif if (is_root_pe()) then diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 584282f27f..9c222bb0bb 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -48,9 +48,9 @@ program MOM_main 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_interpolate, only : time_interp_external_init - use MOM_io, only : file_exists, open_file, close_file + 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, ASCII_FILE, READONLY_FILE, SINGLE_FILE + 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 @@ -238,7 +238,7 @@ program MOM_main if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. - call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) + call open_ASCII_file(unit, 'input.nml', action=READONLY_FILE) read(unit, ocean_solo_nml, iostat=io_status) call close_file(unit) ierr = check_nml_error(io_status,'ocean_solo_nml') @@ -252,15 +252,14 @@ program MOM_main ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then - call open_file(unit,trim(dirs%restart_input_dir)//'ocean_solo.res', & - form=ASCII_FILE,action=READONLY_FILE) + call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ocean_solo.res', action=READONLY_FILE) read(unit,*) calendar_type read(unit,*) date_init read(unit,*) date call close_file(unit) else calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN + if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS @@ -432,15 +431,14 @@ program MOM_main call diag_mediator_close_registration(diag) ! Write out a time stamp file. - if (calendar_type /= NO_CALENDAR) then - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) + if (is_root_pe() .and. (calendar_type /= NO_CALENDAR)) then + call open_ASCII_file(unit, 'time_stamp.out', action=APPEND_FILE) call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + write(unit,'(6i4,2x,a3)') date, month(1:3) call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + write(unit,'(6i4,2x,a3)') date, month(1:3) call close_file(unit) endif @@ -618,19 +616,19 @@ program MOM_main if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) ! Write ocean solo restart file. - call open_file(unit, trim(dirs%restart_output_dir)//'ocean_solo.res', nohdrs=.true.) - if (is_root_pe())then - 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' + if (is_root_pe()) then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'ocean_solo.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 - call close_file(unit) endif if (is_root_pe()) then diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 303809ac06..45b08cc799 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -15,8 +15,7 @@ module MOM_PointAccel 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_io, only : open_file -use MOM_io, only : APPEND_FILE, ASCII_FILE, MULTIPLE, SINGLE_FILE +use MOM_io, only : open_ASCII_file, APPEND_FILE, MULTIPLE, SINGLE_FILE use MOM_time_manager, only : time_type, get_time, get_date, set_date, operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_internal_state, accel_diag_ptrs, cont_diag_ptrs @@ -120,8 +119,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp ! Open up the file for output if this is the first call. if (CS%u_file < 0) then if (len_trim(CS%u_trunc_file) < 1) return - call open_file(CS%u_file, trim(CS%u_trunc_file), action=APPEND_FILE, & - form=ASCII_FILE, threading=MULTIPLE, fileset=SINGLE_FILE) + call open_ASCII_file(CS%u_file, trim(CS%u_trunc_file), action=APPEND_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) if (CS%u_file < 0) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%u_trunc_file)//'.') return @@ -453,8 +452,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp ! Open up the file for output if this is the first call. if (CS%v_file < 0) then if (len_trim(CS%v_trunc_file) < 1) return - call open_file(CS%v_file, trim(CS%v_trunc_file), action=APPEND_FILE, & - form=ASCII_FILE, threading=MULTIPLE, fileset=SINGLE_FILE) + call open_ASCII_file(CS%v_file, trim(CS%v_trunc_file), action=APPEND_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) if (CS%v_file < 0) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%v_trunc_file)//'.') return diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 14a4ceabe3..c35ad64447 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -12,10 +12,10 @@ 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, fieldtype, flush_file, open_file, reopen_file, stdout +use MOM_io, only : create_file, fieldtype, flush_file, open_ASCII_file, reopen_file, stdout use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix use MOM_io, only : field_size, read_variable, read_attribute -use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) @@ -583,11 +583,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! Reopen or create a text output file, with an explanatory header line. if (is_root_pe()) then if (day > CS%Start_time) then - call open_file(CS%fileenergy_ascii, trim(CS%energyfile), & - action=APPEND_FILE, form=ASCII_FILE, nohdrs=.true.) + call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=APPEND_FILE) else - call open_file(CS%fileenergy_ascii, trim(CS%energyfile), & - action=WRITEONLY_FILE, form=ASCII_FILE, nohdrs=.true.) + call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=WRITEONLY_FILE) if (abs(CS%timeunit - 86400.0) < 1.0) then if (CS%use_temperature) then write(CS%fileenergy_ascii,'(" Step,",7x,"Day, Truncs, & diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 050f24db27..30c03033d2 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -14,9 +14,9 @@ module MOM_io use MOM_io_infra, only : MOM_read_data, MOM_read_vector, read_field_chksum use MOM_io_infra, only : read_data=>MOM_read_data ! read_data will be removed soon. use MOM_io_infra, only : file_exists, get_file_info, get_file_fields, get_field_atts -use MOM_io_infra, only : open_file, close_file, get_field_size, fieldtype, field_exists -use MOM_io_infra, only : flush_file, get_filename_suffix -use MOM_io_infra, only : get_file_times, axistype, get_axis_data +use MOM_io_infra, only : open_file, open_ASCII_file, close_file, flush_file +use MOM_io_infra, only : get_field_size, fieldtype, field_exists +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 : 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 @@ -40,8 +40,8 @@ module MOM_io 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, close_file, flush_file, get_filename_appendix -public :: get_file_info, field_exists, get_file_fields, get_file_times +public :: file_exists, open_file, open_ASCII_file, close_file, flush_file +public :: get_file_info, field_exists, get_file_fields, get_file_times, 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 diff --git a/src/framework/MOM_io_infra.F90 b/src/framework/MOM_io_infra.F90 index 978ca71c8a..89bc0067db 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -28,8 +28,8 @@ module MOM_io_infra implicit none ; private ! These interfaces are actually implemented or have explicit interfaces in this file. -public :: open_file, close_file, flush_file, file_exists, get_filename_suffix -public :: get_file_info, get_file_fields, get_file_times +public :: open_file, open_ASCII_file, close_file, flush_file, file_exists +public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix public :: MOM_read_data, MOM_read_vector, write_metadata, write_field public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version @@ -129,14 +129,14 @@ end function FMS_file_exists !> close_file closes a file (or fileset). If the file handle does not point to an open file, !! close_file simply returns without doing anything. subroutine close_file(unit) - integer, intent(out) :: unit !< The I/O unit for the file to be closed + integer, intent(inout) :: unit !< The I/O unit for the file to be closed call mpp_close(unit) end subroutine close_file !> Ensure that the output stream associated with a unit is fully sent to dis. subroutine flush_file(unit) - integer, intent(out) :: unit !< The I/O unit for the file to flush + integer, intent(in) :: unit !< The I/O unit for the file to flush call mpp_flush(unit) end subroutine flush_file @@ -206,6 +206,25 @@ subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domai endif end subroutine open_file +!> open_file opens an ascii file for parallel or single-file I/O. +subroutine open_ASCII_file(unit, file, action, threading, fileset) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< 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) :: 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). + + call mpp_open(unit, file, action=action, form=ASCII_FILE, threading=threading, fileset=fileset, & + nohdrs=.true.) + +end subroutine open_ASCII_file + + !> Provide a string to append to filenames, to differentiate ensemble members, for example. subroutine get_filename_suffix(suffix) character(len=*), intent(out) :: suffix !< A string to append to filenames diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 4ef00707fe..c9200cf41c 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -3,11 +3,11 @@ module MOM_write_cputime ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs, num_pes +use MOM_coms, only : sum_across_PEs, num_pes use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe -use MOM_io, only : open_file, close_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_time_manager, only : time_type, get_time, operator(>) +use MOM_io, only : open_ASCII_file, close_file, APPEND_FILE, WRITEONLY_FILE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_time_manager, only : time_type, get_time, operator(>) implicit none ; private @@ -181,11 +181,9 @@ subroutine write_cputime(day, n, CS, nmax, call_end) ! Reopen or create a text output file. if ((CS%previous_calls == 0) .and. (is_root_pe())) then if (day > CS%Start_time) then - call open_file(CS%fileCPU_ascii, trim(CS%CPUfile), & - action=APPEND_FILE, form=ASCII_FILE, nohdrs=.true.) + call open_ASCII_file(CS%fileCPU_ascii, trim(CS%CPUfile), action=APPEND_FILE) else - call open_file(CS%fileCPU_ascii, trim(CS%CPUfile), & - action=WRITEONLY_FILE, form=ASCII_FILE, nohdrs=.true.) + call open_ASCII_file(CS%fileCPU_ascii, trim(CS%CPUfile), action=WRITEONLY_FILE) endif endif From ae9995c6a4f2e39857cc69db9abfad83daeb728e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Feb 2021 09:03:32 -0500 Subject: [PATCH 208/212] +Add rescale_comp_data & scale to MOM_write_field Added the overloaded interface rescale_comp_data to MOM_domains_infra to rescale the values in the computational domain of a 2-d, 3-d, or 4-d array by some factor without having to know the index convention that those arrays used. Also simplified some of the code in MOM_io_infra by making use of rescale_comp_data, and added a new optional scale argument to the various MOM_write_field routines. All answers are bitwise identical, but there are new interfaces and optional arguments for existing routines. --- src/framework/MOM_array_transform.F90 | 3 +- src/framework/MOM_domain_infra.F90 | 59 +++++++++++++++++++++- src/framework/MOM_domains.F90 | 16 +++--- src/framework/MOM_io.F90 | 72 +++++++++++++++++++++------ src/framework/MOM_io_infra.F90 | 47 ++++++----------- 5 files changed, 138 insertions(+), 59 deletions(-) diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index 179bd6550e..d524f618a3 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -13,9 +13,8 @@ module MOM_array_transform -implicit none +implicit none ; private -private public rotate_array public rotate_array_pair public rotate_vector diff --git a/src/framework/MOM_domain_infra.F90 b/src/framework/MOM_domain_infra.F90 index 68385b1c6d..86e85e60a6 100644 --- a/src/framework/MOM_domain_infra.F90 +++ b/src/framework/MOM_domain_infra.F90 @@ -39,7 +39,7 @@ module MOM_domain_infra ! 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 :: pass_var, pass_vector, fill_symmetric_edges +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 public :: redistribute_array, broadcast_domain, global_field @@ -98,6 +98,11 @@ module MOM_domain_infra ! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d end interface fill_symmetric_edges +!> Rescale the values of an array in its computational domain by a constant factor +interface rescale_comp_data + module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d +end interface rescale_comp_data + !> Pass an array from one MOM domain to another interface redistribute_array module procedure redistribute_array_3d, redistribute_array_2d @@ -1228,6 +1233,57 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) end subroutine redistribute_array_3d +!> Rescale the values of a 4-D array in its computational domain by a constant factor +subroutine rescale_comp_data_4d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + +end subroutine rescale_comp_data_4d + +!> Rescale the values of a 3-D array in its computational domain by a constant factor +subroutine rescale_comp_data_3d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + +end subroutine rescale_comp_data_3d + +!> Rescale the values of a 2-D array in its computational domain by a constant factor +subroutine rescale_comp_data_2d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je) = scale*array(is:ie,js:je) + +end subroutine rescale_comp_data_2d + !> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information !! provided in arguments. subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & @@ -1743,7 +1799,6 @@ subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) end subroutine get_domain_extent_d2D - !> Return the (potentially symmetric) computational domain i-bounds for an array !! passed without index specifications (i.e. indices start at 1) based on an array size. subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 88415c6782..b25a934b97 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -15,7 +15,7 @@ module MOM_domains use MOM_domain_infra, only : pass_vector_start, pass_vector_complete use MOM_domain_infra, only : create_group_pass, do_group_pass use MOM_domain_infra, only : start_group_pass, complete_group_pass -use MOM_domain_infra, only : global_field, redistribute_array, broadcast_domain +use MOM_domain_infra, only : rescale_comp_data, global_field, redistribute_array, broadcast_domain use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE @@ -28,22 +28,24 @@ module MOM_domains implicit none ; private public :: MOM_infra_init, MOM_infra_end -! Domain types and creation and destruction routines +! Domain types and creation and destruction routines public :: MOM_domain_type, domain2D, domain1D public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! Domain query routines +! Domain query routines public :: get_domain_extent, get_domain_components, compute_block_extent, get_global_shape public :: PE_here, root_PE, num_PEs -! Single call communication routines +! Single call communication routines public :: pass_var, pass_vector, fill_symmetric_edges, broadcast -! Non-blocking communication routines +! Non-blocking communication routines public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete -! Multi-variable group communication routines and type +! Multi-variable group communication routines and type public :: create_group_pass, do_group_pass, group_pass_type, start_group_pass, complete_group_pass -! Global reduction routines +! Global reduction routines public :: sum_across_PEs, min_across_PEs, max_across_PEs public :: global_field, redistribute_array, broadcast_domain +! Simple index-convention-invariant array manipulation routine +public :: rescale_comp_data !> These encoding constants are used to indicate the staggering of scalars and vectors public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR !> These encoding constants are used to indicate the discretization position of a variable diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 30c03033d2..ebcccf826b 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -5,7 +5,7 @@ module MOM_io use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_domains, only : MOM_domain_type, domain1D, broadcast, get_domain_components -use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_ensemble_manager, only : get_ensemble_id use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING, is_root_PE @@ -1332,7 +1332,7 @@ end subroutine query_vardesc !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) + fill_value, turns, scale) integer, intent(in) :: io_unit !< File I/O unit handle 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 @@ -1341,18 +1341,24 @@ subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile 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, 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 + integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale - if (qturns == 0) then + if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(io_unit, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -1361,7 +1367,7 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) + fill_value, turns, scale) integer, intent(in) :: io_unit !< File I/O unit handle 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 @@ -1370,18 +1376,24 @@ subroutine MOM_write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile 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, 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 + integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale - if (qturns == 0) then + if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(io_unit, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -1390,7 +1402,7 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns) + fill_value, turns, scale) integer, intent(in) :: io_unit !< File I/O unit handle 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 @@ -1399,19 +1411,24 @@ subroutine MOM_write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile 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 + integer :: is, ie, js, je ! The extent of the computational domain - qturns = 0 - if (present(turns)) qturns = modulo(turns, 4) + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale - if (qturns == 0) then + if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(io_unit, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -1419,25 +1436,50 @@ subroutine MOM_write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile end subroutine MOM_write_field_2d !> Write a 1d field to an output file -subroutine MOM_write_field_1d(io_unit, field_md, field, tstamp, fill_value) +subroutine MOM_write_field_1d(io_unit, field_md, field, tstamp, fill_value, scale) integer, intent(in) :: io_unit !< File I/O unit handle 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(:), allocatable :: array ! A rescaled copy of field + real :: scale_fac ! A scaling factor to use before writing the array + integer :: i - call write_field(io_unit, field_md, field, tstamp=tstamp) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if (scale_fac == 1.0) then + call write_field(io_unit, 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 write_field(io_unit, 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_unit, field_md, field, tstamp, fill_value) +subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value, scale) integer, intent(in) :: io_unit !< File I/O unit handle 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 + + 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 write_field(io_unit, field_md, field, tstamp=tstamp) + call write_field(io_unit, 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_infra.F90 b/src/framework/MOM_io_infra.F90 index 89bc0067db..ba16057615 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -3,8 +3,7 @@ module MOM_io_infra ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE -use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING @@ -397,15 +396,11 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - integer :: is, ie, js, je - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je) = scale*data(is:ie,js:je) + call rescale_comp_data(MOM_Domain, data, scale) endif ; endif end subroutine MOM_read_data_2d @@ -439,8 +434,12 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ endif if (present(scale)) then ; if (scale /= 1.0) then - ! Dangerously rescale the whole array - data(:,:) = scale*data(:,:) + 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 MOM_read_data_2d_region @@ -460,15 +459,11 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - integer :: is, ie, js, je - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je,:) = scale*data(is:ie,js:je,:) + call rescale_comp_data(MOM_Domain, data, scale) endif ; endif end subroutine MOM_read_data_3d @@ -488,15 +483,11 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - integer :: is, ie, js, je - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) - data(is:ie,js:je,:,:) = scale*data(is:ie,js:je,:,:) + call rescale_comp_data(MOM_Domain, data, scale) endif ; endif end subroutine MOM_read_data_4d @@ -544,7 +535,6 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied !! by before they are returned. - integer :: is, ie, js, je integer :: u_pos, v_pos u_pos = EAST_FACE ; v_pos = NORTH_FACE @@ -560,12 +550,8 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data timelevel=timelevel, position=v_pos) if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) - u_data(is:ie,js:je) = scale*u_data(is:ie,js:je) - call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) - v_data(is:ie,js:je) = scale*v_data(is:ie,js:je) + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) endif ; endif end subroutine MOM_read_vector_2d @@ -589,7 +575,6 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied !! by before they are returned. - integer :: is, ie, js, je integer :: u_pos, v_pos u_pos = EAST_FACE ; v_pos = NORTH_FACE @@ -605,12 +590,8 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data timelevel=timelevel, position=v_pos) if (present(scale)) then ; if (scale /= 1.0) then - call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) - u_data(is:ie,js:je,:) = scale*u_data(is:ie,js:je,:) - call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) - call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) - v_data(is:ie,js:je,:) = scale*v_data(is:ie,js:je,:) + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) endif ; endif end subroutine MOM_read_vector_3d From 76b9ffa801d322563afb9cbab18afc50d0e26ab8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Feb 2021 09:04:30 -0500 Subject: [PATCH 209/212] Simplify write_ocean_geometry_file Use the new scale argument to MOM_write_field to simplify write_vertgrid_file and write_ocean_geometry_file. All output and answers are bitwise identical. --- .../MOM_coord_initialization.F90 | 6 +- .../MOM_shared_initialization.F90 | 112 ++++++------------ 2 files changed, 37 insertions(+), 81 deletions(-) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 454060414b..09f3895ded 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 : MOM_read_data, close_file, create_file, fieldtype, file_exists -use MOM_io, only : write_field, vardesc, var_desc, SINGLE_FILE, MULTIPLE +use MOM_io, only : MOM_write_field, vardesc, var_desc, SINGLE_FILE, MULTIPLE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -526,8 +526,8 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) call create_file(unit, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call write_field(unit, fields(1), US%R_to_kg_m3*GV%Rlay(:)) - call write_field(unit, fields(2), US%L_T_to_m_s**2*US%m_to_Z*GV%g_prime(:)) + call MOM_write_field(unit, fields(1), GV%Rlay, scale=US%R_to_kg_m3) + call MOM_write_field(unit, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) call close_file(unit) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 24c09a881c..3ceb46698c 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1195,36 +1195,24 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) integer :: unit integer :: file_threading integer :: nFlds_used - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB logical :: multiple_files - real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: out_h - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: out_q - real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: out_u - real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: out_v call callTree_enter('write_ocean_geometry_file()') - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - Z_to_m_scale = 1.0 ; if (present(US)) Z_to_m_scale = US%Z_to_m s_to_T_scale = 1.0 ; if (present(US)) s_to_T_scale = US%s_to_T L_to_m_scale = 1.0 ; if (present(US)) L_to_m_scale = US%L_to_m -! vardesc is a structure defined in MOM_io.F90. The elements of -! this structure, in order, are: -! (1) the variable name for the NetCDF file -! (2) the variable's long name -! (3) a character indicating the horizontal grid, which may be '1' (column), -! 'h', 'q', 'u', or 'v', for the corresponding C-grid variable -! (4) a character indicating the vertical grid, which may be 'L' (layer), -! 'i' (interface), or '1' (no vertical location) -! (5) a character indicating the time levels of the field, which may be -! 's' (snap-shot), 'p' (periodic), or '1' (no time variation) -! (6) the variable's units + ! var_desc populates a type defined in MOM_io.F90. The arguments, in order, are: + ! (1) the variable name for the NetCDF file + ! (2) the units of the variable when output + ! (3) the variable's long name + ! (4) a character indicating the horizontal grid, which may be '1' (column), + ! 'h', 'q', 'u', or 'v', for the corresponding C-grid variable + ! (5) a character indicating the vertical grid, which may be 'L' (layer), + ! 'i' (interface), or '1' (no vertical location) + ! (6) a character indicating the time levels of the field, which may be + ! 's' (snap-shot), 'p' (periodic), or '1' (no time variation) vars(1) = var_desc("geolatb","degree","latitude at corner (Bu) points",'q','1','1') vars(2) = var_desc("geolonb","degree","longitude at corner (Bu) points",'q','1','1') vars(3) = var_desc("geolat","degree", "latitude at tracer (T) points", 'h','1','1') @@ -1260,11 +1248,6 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) filepath = trim(directory) // "ocean_geometry" endif - out_h(:,:) = 0.0 - out_u(:,:) = 0.0 - out_v(:,:) = 0.0 - out_q(:,:) = 0.0 - call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & @@ -1272,64 +1255,37 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(unit, trim(filepath), vars, nFlds_used, fields, & - file_threading, dG=G) + call create_file(unit, trim(filepath), vars, nFlds_used, fields, file_threading, dG=G) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLatBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(1), G%Domain, out_q) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = G%geoLonBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(2), G%Domain, out_q) + call MOM_write_field(unit, fields(1), G%Domain, G%geoLatBu) + call MOM_write_field(unit, fields(2), G%Domain, G%geoLonBu) call MOM_write_field(unit, fields(3), G%Domain, G%geoLatT) call MOM_write_field(unit, fields(4), G%Domain, G%geoLonT) - do j=js,je ; do i=is,ie ; out_h(i,j) = Z_to_m_scale*G%bathyT(i,j) ; enddo ; enddo - call MOM_write_field(unit, fields(5), G%Domain, out_h) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(i,J) = s_to_T_scale*G%CoriolisBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(6), G%Domain, out_q) - - ! I think that all of these copies are holdovers from a much earlier - ! ancestor code in which many of the metrics were macros that could have - ! had reduced dimensions, and that they are no longer needed in MOM6. -RWH - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dxCv(i,J) ; enddo ; enddo - call MOM_write_field(unit, fields(7), G%Domain, out_v) - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dyCu(I,j) ; enddo ; enddo - call MOM_write_field(unit, fields(8), G%Domain, out_u) - - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dxCu(I,j) ; enddo ; enddo - call MOM_write_field(unit, fields(9), G%Domain, out_u) - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dyCv(i,J) ; enddo ; enddo - call MOM_write_field(unit, fields(10), G%Domain, out_v) - - do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale*G%dxT(i,j); enddo ; enddo - call MOM_write_field(unit, fields(11), G%Domain, out_h) - do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale*G%dyT(i,j) ; enddo ; enddo - call MOM_write_field(unit, fields(12), G%Domain, out_h) - - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(i,J) = L_to_m_scale*G%dxBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(13), G%Domain, out_q) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = L_to_m_scale*G%dyBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(14), G%Domain, out_q) - - do j=js,je ; do i=is,ie ; out_h(i,j) = L_to_m_scale**2*G%areaT(i,j) ; enddo ; enddo - call MOM_write_field(unit, fields(15), G%Domain, out_h) - do J=Jsq,Jeq ; do I=Isq,Ieq ; out_q(I,J) = L_to_m_scale**2*G%areaBu(I,J) ; enddo ; enddo - call MOM_write_field(unit, fields(16), G%Domain, out_q) - - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = L_to_m_scale*G%dx_Cv(i,J) ; enddo ; enddo - call MOM_write_field(unit, fields(17), G%Domain, out_v) - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = L_to_m_scale*G%dy_Cu(I,j) ; enddo ; enddo - call MOM_write_field(unit, fields(18), G%Domain, out_u) + call MOM_write_field(unit, fields(5), G%Domain, G%bathyT, scale=Z_to_m_scale) + call MOM_write_field(unit, fields(6), G%Domain, G%CoriolisBu, scale=s_to_T_scale) + + call MOM_write_field(unit, fields(7), G%Domain, G%dxCv, scale=L_to_m_scale) + call MOM_write_field(unit, fields(8), G%Domain, G%dyCu, scale=L_to_m_scale) + call MOM_write_field(unit, fields(9), G%Domain, G%dxCu, scale=L_to_m_scale) + call MOM_write_field(unit, fields(10), G%Domain, G%dyCv, scale=L_to_m_scale) + call MOM_write_field(unit, fields(11), G%Domain, G%dxT, scale=L_to_m_scale) + call MOM_write_field(unit, fields(12), G%Domain, G%dyT, scale=L_to_m_scale) + call MOM_write_field(unit, fields(13), G%Domain, G%dxBu, scale=L_to_m_scale) + call MOM_write_field(unit, fields(14), G%Domain, G%dyBu, scale=L_to_m_scale) + + call MOM_write_field(unit, fields(15), G%Domain, G%areaT, scale=L_to_m_scale**2) + call MOM_write_field(unit, fields(16), G%Domain, G%areaBu, scale=L_to_m_scale**2) + + call MOM_write_field(unit, fields(17), G%Domain, G%dx_Cv, scale=L_to_m_scale) + call MOM_write_field(unit, fields(18), G%Domain, G%dy_Cu, scale=L_to_m_scale) call MOM_write_field(unit, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dblock_u(I,j) ; enddo ; enddo - call MOM_write_field(unit, fields(20), G%Domain, out_u) - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dopen_u(I,j) ; enddo ; enddo - call MOM_write_field(unit, fields(21), G%Domain, out_u) - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dblock_v(i,J) ; enddo ; enddo - call MOM_write_field(unit, fields(22), G%Domain, out_v) - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dopen_v(i,J) ; enddo ; enddo - call MOM_write_field(unit, fields(23), G%Domain, out_v) + call MOM_write_field(unit, fields(20), G%Domain, G%Dblock_u, scale=Z_to_m_scale) + call MOM_write_field(unit, fields(21), G%Domain, G%Dopen_u, scale=Z_to_m_scale) + call MOM_write_field(unit, fields(22), G%Domain, G%Dblock_v, scale=Z_to_m_scale) + call MOM_write_field(unit, fields(23), G%Domain, G%Dopen_v, scale=Z_to_m_scale) endif call close_file(unit) From 21c269684236ed10ab64df7095abad493018b75d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Feb 2021 18:38:43 -0500 Subject: [PATCH 210/212] +Use file_type as the handle for I/O Added and used the file_type as the handle for input and output, changing from using an integer. This changes the type of one of the required arguments to write_field, write_MOM_field, create_file, reopen_file, get_file_info, get_file_times, get_file_fields, write_metadata_axis and write_metadata_field, and added new variants of open_file, close_file and flush_file using this new type. Also added the new routine file_is_open. All answers are bitwise identical, but there are changes to multiple I/O interfaces. --- src/ALE/MOM_ALE.F90 | 13 +- src/diagnostics/MOM_sum_output.F90 | 6 +- src/framework/MOM_io.F90 | 116 +++++----- src/framework/MOM_io_infra.F90 | 204 ++++++++++++------ src/framework/MOM_restart.F90 | 64 +++--- .../MOM_coord_initialization.F90 | 15 +- .../MOM_shared_initialization.F90 | 64 +++--- .../MOM_state_initialization.F90 | 6 +- 8 files changed, 282 insertions(+), 206 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index fe1563232f..4523f029bf 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -22,7 +22,7 @@ module MOM_ALE use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, param_file_type, log_param use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE -use MOM_io, only : create_file, write_field, close_file +use MOM_io, only : create_file, write_field, close_file, file_type use MOM_interface_heights,only : find_eta use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S @@ -1273,7 +1273,7 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=240) :: filepath type(vardesc) :: vars(2) type(fieldtype) :: fields(2) - integer :: unit + type(file_type) :: IO_handle ! The I/O handle of the fileset real :: ds(GV%ke), dsi(GV%ke+1) filepath = trim(directory) // trim("Vertical_coordinate") @@ -1287,14 +1287,13 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) vars(2) = var_desc('ds_interface', getCoordinateUnits( CS%regridCS ), & 'Layer Center Coordinate Separation','1','i','1') - call create_file(unit, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call write_field(unit, fields(1), ds) - call write_field(unit, fields(2), dsi) - call close_file(unit) + call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call write_field(IO_handle, fields(1), ds) + call write_field(IO_handle, fields(2), dsi) + call close_file(IO_handle) end subroutine ALE_writeCoordinateFile - !> Set h to coordinate values for fixed coordinate systems subroutine ALE_initThicknessToCoord( CS, G, GV, h ) type(ALE_CS), intent(inout) :: CS !< module control structure diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index c35ad64447..70ec9404d1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -12,9 +12,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, fieldtype, flush_file, open_ASCII_file, reopen_file, stdout +use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix -use MOM_io, only : field_size, read_variable, read_attribute +use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -122,7 +122,7 @@ 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. - integer :: fileenergy_nc !< NetCDF id of the energy file. + type(file_type) :: 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_) :: & fields !< fieldtype variables for the output fields. diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index ebcccf826b..51253d2e20 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -13,9 +13,9 @@ module MOM_io use MOM_grid, only : ocean_grid_type use MOM_io_infra, only : MOM_read_data, MOM_read_vector, read_field_chksum use MOM_io_infra, only : read_data=>MOM_read_data ! read_data will be removed soon. -use MOM_io_infra, only : file_exists, get_file_info, get_file_fields, get_field_atts -use MOM_io_infra, only : open_file, open_ASCII_file, close_file, flush_file -use MOM_io_infra, only : get_field_size, fieldtype, field_exists +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 : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end @@ -40,7 +40,7 @@ module MOM_io 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 +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 :: fieldtype, field_size, get_field_atts public :: axistype, get_axis_data @@ -101,12 +101,12 @@ module MOM_io contains -!> Routine creates a new NetCDF file. It also sets up +!> 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. Type for describing a variable, typically a tracer -subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) - integer, intent(out) :: unit !< unit id of an open file or -1 on a - !! nonwriting PE with single file output +!! later be written to this file. +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) + 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 @@ -173,9 +173,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, threading=thread) + call open_file(IO_handle, filename, OVERWRITE_FILE, threading=thread) else - call open_file(unit, filename, OVERWRITE_FILE, NETCDF_FILE, MOM_domain=Domain) + call open_file(IO_handle, filename, OVERWRITE_FILE, MOM_domain=Domain) endif ! Define the coordinates. @@ -245,28 +245,28 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit "create_file: A vertical grid type is required to create a file with a vertical coordinate.") if (use_lath) & - call write_metadata(unit, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & + call write_metadata(IO_handle, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatT(jsg:jeg)) if (use_lonh) & - call write_metadata(unit, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & + call write_metadata(IO_handle, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonT(isg:ieg)) if (use_latq) & - call write_metadata(unit, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & + call write_metadata(IO_handle, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB)) if (use_lonq) & - call write_metadata(unit, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & + call write_metadata(IO_handle, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB)) if (use_layer) & - call write_metadata(unit, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & + call write_metadata(IO_handle, axis_layer, name="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(unit, axis_int, name="Interface", units=trim(GV%zAxisUnits), & + call write_metadata(IO_handle, axis_int, name="Interface", units=trim(GV%zAxisUnits), & longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & sense=1, data=GV%sInterface(1:GV%ke+1)) @@ -286,9 +286,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit write(time_units,'(es8.2," s")') timeunit endif - call write_metadata(unit, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') + call write_metadata(IO_handle, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') else - call write_metadata(unit, axis_time, name="Time", units="days", longname="Time", cartesian= 'T') + call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian= 'T') endif ; endif if (use_periodic) then @@ -297,7 +297,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit ! Define a periodic axis with unit labels. allocate(period_val(num_periods)) do k=1,num_periods ; period_val(k) = real(k) ; enddo - call write_metadata(unit, axis_periodic, name="Period", units="nondimensional", & + call write_metadata(IO_handle, axis_periodic, name="Period", units="nondimensional", & longname="Periods for cyclical varaiables", cartesian='T', data=period_val) deallocate(period_val) endif @@ -338,21 +338,21 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit pack = 1 if (present(checksums)) then - call write_metadata(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack=pack, checksum=checksums(k,:)) else - call write_metadata(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack=pack) endif enddo - if (use_lath) call write_field(unit, axis_lath) - if (use_latq) call write_field(unit, axis_latq) - if (use_lonh) call write_field(unit, axis_lonh) - if (use_lonq) call write_field(unit, axis_lonq) - if (use_layer) call write_field(unit, axis_layer) - if (use_int) call write_field(unit, axis_int) - if (use_periodic) call write_field(unit, axis_periodic) + 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) end subroutine create_file @@ -361,9 +361,9 @@ end subroutine create_file !! 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(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV) - integer, intent(out) :: unit !< unit id of an open file or -1 on a - !! nonwriting PE with single file output +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV) + 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 @@ -397,7 +397,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit inquire(file=check_name,EXIST=exists) if (.not.exists) then - call create_file(unit, filename, vars, novars, fields, threading, timeunit, & + call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & G=G, dG=dG, GV=GV) else @@ -412,26 +412,26 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, threading=thread) + call open_file(IO_handle, filename, APPEND_FILE, threading=thread) else - call open_file(unit, filename, APPEND_FILE, NETCDF_FILE, MOM_domain=Domain) + call open_file(IO_handle, filename, APPEND_FILE, MOM_domain=Domain) endif - if (unit < 0) return + if (.not.file_is_open(IO_handle)) return - call get_file_info(unit, ndim, nvar, natt, ntime) + call get_file_info(IO_handle, ndim, nvar, natt, ntime) 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(unit, filename, vars, novars, fields, threading, timeunit, G=G, GV=GV) + call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G=G, GV=GV) 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(unit, fields(1:nvar)) + if (nvar > 0) call get_file_fields(IO_handle, fields(1:nvar)) ! Check for inconsistent field names... ! do i=1,nvar @@ -1331,9 +1331,9 @@ end subroutine query_vardesc !> Write a 4d field to an output file, potentially with rotation -subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - integer, intent(in) :: io_unit !< File I/O unit handle + type(file_type), intent(in) :: 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 @@ -1353,22 +1353,22 @@ subroutine MOM_write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile scale_fac = 1.0 ; if (present(scale)) scale_fac = scale if ((qturns == 0) .and. (scale_fac == 1.0)) then - call write_field(io_unit, field_md, MOM_domain, field, tstamp=tstamp, & + call write_field(IO_handle, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & + call write_field(IO_handle, 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_unit, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - integer, intent(in) :: io_unit !< File I/O unit handle + type(file_type), intent(in) :: 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 @@ -1388,22 +1388,22 @@ subroutine MOM_write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile scale_fac = 1.0 ; if (present(scale)) scale_fac = scale if ((qturns == 0) .and. (scale_fac == 1.0)) then - call write_field(io_unit, field_md, MOM_domain, field, tstamp=tstamp, & + call write_field(IO_handle, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & + call write_field(IO_handle, 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_unit, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - integer, intent(in) :: io_unit !< File I/O unit handle + type(file_type), intent(in) :: 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 @@ -1423,21 +1423,21 @@ subroutine MOM_write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile scale_fac = 1.0 ; if (present(scale)) scale_fac = scale if ((qturns == 0) .and. (scale_fac == 1.0)) then - call write_field(io_unit, field_md, MOM_domain, field, tstamp=tstamp, & + call write_field(IO_handle, 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 write_field(io_unit, field_md, MOM_domain, field_rot, tstamp=tstamp, & + call write_field(IO_handle, 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_unit, field_md, field, tstamp, fill_value, scale) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) + type(file_type), intent(in) :: 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 @@ -1452,21 +1452,21 @@ subroutine MOM_write_field_1d(io_unit, field_md, field, tstamp, fill_value, scal scale_fac = 1.0 ; if (present(scale)) scale_fac = scale if (scale_fac == 1.0) then - call write_field(io_unit, field_md, field, tstamp=tstamp) + call write_field(IO_handle, 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 write_field(io_unit, field_md, array, tstamp=tstamp) + call write_field(IO_handle, 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_unit, field_md, field, tstamp, fill_value, scale) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) + type(file_type), intent(in) :: 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 @@ -1479,7 +1479,7 @@ subroutine MOM_write_field_0d(io_unit, field_md, field, tstamp, fill_value, scal if (present(scale)) scaled_val = scale*field if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif - call write_field(io_unit, field_md, scaled_val, tstamp=tstamp) + call write_field(IO_handle, 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_infra.F90 b/src/framework/MOM_io_infra.F90 index ba16057615..3ea201235a 100644 --- a/src/framework/MOM_io_infra.F90 +++ b/src/framework/MOM_io_infra.F90 @@ -18,16 +18,16 @@ module MOM_io_infra use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init ! These are encoding constants. -use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, ASCII_FILE=>MPP_ASCII -use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, NETCDF_FILE=>MPP_NETCDF +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 : SINGLE_FILE=>MPP_SINGLE, WRITEONLY_FILE=>MPP_WRONLY +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 ! These interfaces are actually implemented or have explicit interfaces in this file. -public :: open_file, open_ASCII_file, close_file, flush_file, file_exists +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 public :: MOM_read_data, MOM_read_vector, write_metadata, write_field public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum @@ -36,8 +36,8 @@ module MOM_io_infra ! information about fields and axes, respectively, and are opaque to this module. public :: fieldtype, axistype ! These are encoding constant parmeters. -public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE -public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE +public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE +public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE public :: CENTER, CORNER, NORTH_FACE, EAST_FACE !> Indicate whether a file exists, perhaps with domain decomposition @@ -46,6 +46,11 @@ module MOM_io_infra module procedure MOM_file_exists end interface +!> Open a file (or fileset) for parallel or single-file I/). +interface open_file + module procedure open_file_type, open_file_unit +end interface open_file + !> Read a data field from a file interface MOM_read_data module procedure MOM_read_data_4d @@ -76,6 +81,25 @@ module MOM_io_infra module procedure write_metadata_axis, write_metadata_field end interface write_metadata +!> Close a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +interface close_file + 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, public :: file_type ; private + integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + character(len=:), allocatable :: filename !< The path to this file, if it is open + logical :: open_to_read = .false. !< If true, this file or fileset can be read + logical :: open_to_write = .false. !< If true, this file or fileset can be written to +end type file_type + contains !> Reads the checksum value for a field that was recorded in a file, along with a flag indicating @@ -98,47 +122,67 @@ subroutine read_field_chksum(field, chksum, valid_chksum) end subroutine read_field_chksum !> Returns true if the named file or its domain-decomposed variant exists. -function MOM_file_exists(filename, MOM_Domain) +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. - logical :: MOM_file_exists - MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) end function MOM_file_exists !> Returns true if the named file or its domain-decomposed variant exists. -function FMS_file_exists(filename, domain, no_domain) +logical function FMS_file_exists(filename, domain, no_domain) character(len=*), intent(in) :: filename !< The name of the file being inquired about type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition ! This function uses the fms_io function file_exist to determine whether ! a named file (or its decomposed variant) exists. - logical :: FMS_file_exists - FMS_file_exists = file_exist(filename, domain, no_domain) end function FMS_file_exists -!> close_file closes a file (or fileset). If the file handle does not point to an open file, -!! close_file simply returns without doing anything. -subroutine close_file(unit) +!> indicates whether an I/O handle is attached to an open file +logical function file_is_open(IO_handle) + type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about + + file_is_open = (IO_handle%unit >= 0) +end function file_is_open + +!> closes a file (or fileset). If the file handle does not point to an open file, +!! close_file_type simply returns without doing anything. +subroutine close_file_type(IO_handle) + type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed + + call mpp_close(IO_handle%unit) + if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. +end subroutine close_file_type + +!> 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(unit) integer, intent(inout) :: unit !< The I/O unit for the file to be closed call mpp_close(unit) -end subroutine close_file +end subroutine close_file_unit -!> Ensure that the output stream associated with a unit is fully sent to dis. -subroutine flush_file(unit) - integer, intent(in) :: unit !< The I/O unit for the file to flush +!> Ensure that the output stream associated with a file handle is fully sent to disk. +subroutine flush_file_type(file) + type(file_type), intent(in) :: file !< The I/O handle for the file to flush + + call mpp_flush(file%unit) +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 +end subroutine flush_file_unit !> Initialize the underlying I/O infrastructure subroutine io_infra_init(maxunits) @@ -178,9 +222,9 @@ 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, file, action, form, threading, fileset, nohdrs, domain, MOM_domain) +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) :: file !< The name of the file being opened + 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 @@ -197,15 +241,51 @@ subroutine open_file(unit, file, action, form, threading, fileset, nohdrs, domai 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, file, action=action, form=form, threading=threading, fileset=fileset, & + 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, file, action=action, form=form, threading=threading, fileset=fileset, & + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & nohdrs=nohdrs, domain=domain) endif -end subroutine open_file +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) + 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 + !! 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). + + if (present(MOM_Domain)) then + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset, domain=MOM_Domain%mpp_domain) + else + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset) + endif + IO_handle%filename = trim(filename) + if (present(action)) then + if (action == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + +end subroutine open_file_type -!> open_file opens an ascii file for parallel or single-file I/O. +!> 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) integer, intent(out) :: unit !< The I/O unit for the opened file character(len=*), intent(in) :: file !< The name of the file being opened @@ -234,8 +314,8 @@ end subroutine get_filename_suffix !> Get information about the number of dimensions, variables, global attributes and time levels !! in the file associated with an open file unit -subroutine get_file_info(unit, ndim, nvar, natt, ntime) - integer, intent(in) :: unit !< The I/O unit for the open file +subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) + type(file_type), intent(in) :: IO_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) :: natt !< The number of global attributes in the file @@ -244,7 +324,7 @@ subroutine get_file_info(unit, ndim, nvar, natt, ntime) ! Local variables integer :: ndims, nvars, natts, ntimes - call mpp_get_info( unit, ndims, nvars, natts, ntimes ) + call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) if (present(ndim)) ndim = ndims if (present(nvar)) nvar = nvars @@ -256,29 +336,29 @@ end subroutine get_file_info !> Get the times of records from a file !### Modify this to also convert to time_type, using information about the dimensions? -subroutine get_file_times(unit, time_values, ntime) - integer, intent(in) :: unit !< The I/O unit for the open file +subroutine get_file_times(IO_handle, time_values, ntime) + type(file_type), intent(in) :: IO_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 integer :: ntimes if (allocated(time_values)) deallocate(time_values) - call get_file_info(unit, ntime=ntimes) + call get_file_info(IO_handle, ntime=ntimes) if (present(ntime)) ntime = ntimes if (ntimes > 0) then allocate(time_values(ntimes)) - call mpp_get_times(unit, time_values) + call mpp_get_times(IO_handle%unit, time_values) endif end subroutine get_file_times !> Set up the field information (e.g., names and metadata) for all of the variables in a file. The !! argument fields must be allocated with a size that matches the number of variables in a file. -subroutine get_file_fields(unit, fields) - integer, intent(in) :: unit !< The I/O unit for the open file +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. - call mpp_get_fields(unit, fields) + call mpp_get_fields(IO_handle%unit, fields) end subroutine get_file_fields !> Extract information from a field type, as stored or as found in a file @@ -598,8 +678,8 @@ end subroutine MOM_read_vector_3d !> Write a 4d field to an output file. -subroutine write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: 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 !< Field to write @@ -607,13 +687,13 @@ subroutine write_field_4d(io_unit, field_md, MOM_domain, field, tstamp, tile_cou integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & tile_count=tile_count, default_data=fill_value) end subroutine write_field_4d !> Write a 3d field to an output file. -subroutine write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: 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 !< Field to write @@ -621,13 +701,13 @@ subroutine write_field_3d(io_unit, field_md, MOM_domain, field, tstamp, tile_cou integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & tile_count=tile_count, default_data=fill_value) end subroutine write_field_3d !> Write a 2d field to an output file. -subroutine write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: 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 !< Field to write @@ -635,43 +715,43 @@ subroutine write_field_2d(io_unit, field_md, MOM_domain, field, tstamp, tile_cou integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(io_unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & tile_count=tile_count, default_data=fill_value) end subroutine write_field_2d !> Write a 1d field to an output file. -subroutine write_field_1d(io_unit, field_md, field, tstamp) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine write_field_1d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: 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 - call mpp_write(io_unit, field_md, field, tstamp=tstamp) + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_1d !> Write a 0d field to an output file. -subroutine write_field_0d(io_unit, field_md, field, tstamp) - integer, intent(in) :: io_unit !< File I/O unit handle +subroutine write_field_0d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: 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 - call mpp_write(io_unit, field_md, field, tstamp=tstamp) + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_0d !> Write the data for an axis -subroutine MOM_write_axis(io_unit, axis) - integer, intent(in) :: io_unit !< File I/O unit handle - type(axistype), intent(in) :: axis !< An axis type variable with information to write +subroutine MOM_write_axis(IO_handle, axis) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(in) :: axis !< An axis type variable with information to write - call mpp_write(io_unit, axis) + call mpp_write(IO_handle%unit, axis) end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this !! information to the file indicated by unit. -subroutine write_metadata_axis( unit, axis, name, units, longname, cartesian, sense, domain, data, calendar) - integer, intent(in) :: unit !< The I/O unit for the file to write to +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, calendar) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(inout) :: axis !< The axistype where this information is stored. character(len=*), intent(in) :: name !< The name in the file of this axis character(len=*), intent(in) :: units !< The units of this axis @@ -685,15 +765,15 @@ subroutine write_metadata_axis( unit, axis, name, units, longname, cartesian, se real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis - call mpp_write_meta(unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & + call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & domain=domain, data=data, calendar=calendar) end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this !! information to the file indicated by unit. -subroutine write_metadata_field(unit, field, axes, name, units, longname, & +subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & min, max, fill, scale, add, pack, standard_name, checksum) - integer, intent(in) :: unit !< The I/O unit for the file to write to + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable character(len=*), intent(in) :: name !< The name in the file of this variable @@ -713,8 +793,8 @@ subroutine write_metadata_field(unit, field, axes, name, units, longname, & optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. - call mpp_write_meta( unit, field, axes, name, units, longname, & - min=min, max=max, fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, min=min, max=max, & + fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) end subroutine write_metadata_field diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 29500875ca..0625177d77 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -8,11 +8,11 @@ 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, fieldtype, file_exists, open_file, close_file +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 use MOM_io, only : get_file_info, get_file_fields, get_field_atts, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix -use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE +use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type, time_type_to_real, real_to_time @@ -874,7 +874,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! this should be 2 Gb or less. integer :: start_var, next_var ! The starting variables of the ! current and next files. - integer :: unit ! The I/O unit of the open file. + type(file_type) :: IO_handle ! The I/O handle of the open fileset integer :: m, nz, num_files, var_periods integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. @@ -1020,33 +1020,31 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo if (CS%parallel_restartfiles) then - call create_file(unit, trim(restartpath), vars, (next_var-start_var), & + call create_file(IO_handle, trim(restartpath), vars, (next_var-start_var), & fields, MULTIPLE, G=G, GV=GV, checksums=check_val) else - call create_file(unit, trim(restartpath), vars, (next_var-start_var), & + call create_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 if (associated(CS%var_ptr3d(m)%p)) then - call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & CS%var_ptr3d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & CS%var_ptr2d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - call MOM_write_field(unit,fields(m-start_var+1), G%Domain, & + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & CS%var_ptr4d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - call MOM_write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & - restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, restart_time) elseif (associated(CS%var_ptr0d(m)%p)) then - call MOM_write_field(unit, fields(m-start_var+1), CS%var_ptr0d(m)%p, & - restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, restart_time) endif enddo - call close_file(unit) + call close_file(IO_handle) num_files = num_files+1 @@ -1086,7 +1084,7 @@ subroutine restore_state(filename, directory, day, G, CS) integer :: sizes(7) integer :: nvar, ntime, pos - integer :: unit(CS%max_fields) ! The I/O units of all open files. + type(file_type) :: 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. @@ -1104,10 +1102,10 @@ subroutine restore_state(filename, directory, day, G, CS) ! Get NetCDF ids for all of the restart files. if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then - num_file = open_restart_units('r', directory, G, CS, units=unit, & + num_file = open_restart_units('r', directory, G, CS, IO_handles=IO_handles, & file_paths=unit_path, global_files=unit_is_global) else - num_file = open_restart_units(filename, directory, G, CS, units=unit, & + num_file = open_restart_units(filename, directory, G, CS, IO_handles=IO_handles, & file_paths=unit_path, global_files=unit_is_global) endif @@ -1119,7 +1117,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(unit(n), time_vals, ntime) + call get_file_times(IO_handles(n), time_vals, ntime) if (ntime < 1) cycle t1 = time_vals(1) @@ -1136,7 +1134,7 @@ subroutine restore_state(filename, directory, day, G, CS) ! if they differ from the first time. if (is_root_pe()) then do m = n+1,num_file - call get_file_times(unit(n), time_vals, ntime) + call get_file_times(IO_handles(n), time_vals, ntime) if (ntime < 1) cycle t2 = time_vals(1) @@ -1153,10 +1151,10 @@ 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(unit(n), nvar=nvar) + call get_file_info(IO_handles(n), nvar=nvar) allocate(fields(nvar)) - call get_file_fields(unit(n), fields(1:nvar)) + call get_file_fields(IO_handles(n), fields(1:nvar)) do m=1, nvar call get_field_atts(fields(m), name=varname) @@ -1262,7 +1260,7 @@ subroutine restore_state(filename, directory, day, G, CS) enddo do n=1,num_file - call close_file(unit(n)) + call close_file(IO_handles(n)) enddo ! Check whether any mandatory fields have not been found. @@ -1355,7 +1353,7 @@ end function is_new_run !> open_restart_units determines the number of existing restart files and optionally opens !! them and returns unit ids, paths and whether the files are global or spatially decomposed. -function open_restart_units(filename, directory, G, CS, units, file_paths, & +function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, & global_files) result(num_files) character(len=*), intent(in) :: filename !< The list of restart file names or a single !! character 'r' to read automatically named files. @@ -1363,8 +1361,8 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous !! call to restart_init. - integer, dimension(:), & - optional, intent(out) :: units !< The I/O units of all opened files. + type(file_type), 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. logical, dimension(:), & @@ -1444,22 +1442,22 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & num_restart = num_restart + 1 inquire(file=filepath, exist=fexists) if (fexists) then - if (present(units)) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & + if (present(IO_handles)) & + call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(n) = .true. elseif (CS%parallel_restartfiles) then ! Look for decomposed files using the I/O Layout. fexists = file_exists(filepath, G%Domain) - if (fexists .and. (present(units))) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, MOM_domain=G%Domain) + if (fexists .and. (present(IO_handles))) & + call open_file(IO_handles(n), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) if (fexists .and. present(global_files)) global_files(n) = .false. endif if (fexists) then if (present(file_paths)) file_paths(n) = filepath n = n + 1 - if (is_root_pe() .and. (present(units))) & + if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) else err = 1 ; exit @@ -1472,16 +1470,16 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & inquire(file=filepath, exist=fexists) if (fexists) then - if (present(units)) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & + if (present(IO_handles)) & + call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(n) = .true. if (present(file_paths)) file_paths(n) = filepath n = n + 1 - if (is_root_pe() .and. (present(units))) & + if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) else - if (present(units)) & + if (present(IO_handles)) & call MOM_error(WARNING,"MOM_restart: Unable to find restart file : "//trim(filepath)) endif diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 09f3895ded..4f04fb285f 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -8,8 +8,9 @@ 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 : MOM_read_data, close_file, create_file, fieldtype, file_exists -use MOM_io, only : MOM_write_field, vardesc, var_desc, SINGLE_FILE, MULTIPLE +use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc +use MOM_io, only : SINGLE_FILE, MULTIPLE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -517,19 +518,19 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) character(len=240) :: filepath type(vardesc) :: vars(2) type(fieldtype) :: fields(2) - integer :: unit + type(file_type) :: 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(unit, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call MOM_write_field(unit, fields(1), GV%Rlay, scale=US%R_to_kg_m3) - call MOM_write_field(unit, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) + 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(unit) + call close_file(IO_handle) end subroutine write_vertgrid_file diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 3ceb46698c..70ef0768d5 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -11,9 +11,9 @@ 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, fieldtype, file_exists, field_size, stdout -use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, SINGLE_FILE, MULTIPLE -use MOM_io, only : open_file_to_read, close_file_to_read +use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists, field_size +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 use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -1189,10 +1189,10 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) integer, parameter :: nFlds=23 type(vardesc) :: vars(nFlds) type(fieldtype) :: fields(nFlds) - real :: Z_to_m_scale ! A unit conversion factor from Z to m. - real :: s_to_T_scale ! A unit conversion factor from T-1 to s-1. - real :: L_to_m_scale ! A unit conversion factor from L to m. - integer :: unit + real :: Z_to_m_scale ! A unit conversion factor from Z to m + real :: s_to_T_scale ! A unit conversion factor from T-1 to s-1 + real :: L_to_m_scale ! A unit conversion factor from L to m + type(file_type) :: IO_handle ! The I/O handle of the fileset integer :: file_threading integer :: nFlds_used logical :: multiple_files @@ -1255,40 +1255,40 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(unit, trim(filepath), vars, nFlds_used, fields, file_threading, dG=G) + call create_file(IO_handle, trim(filepath), vars, nFlds_used, fields, file_threading, dG=G) - call MOM_write_field(unit, fields(1), G%Domain, G%geoLatBu) - call MOM_write_field(unit, fields(2), G%Domain, G%geoLonBu) - call MOM_write_field(unit, fields(3), G%Domain, G%geoLatT) - call MOM_write_field(unit, fields(4), G%Domain, G%geoLonT) + call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) + call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) + call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) + call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) - call MOM_write_field(unit, fields(5), G%Domain, G%bathyT, scale=Z_to_m_scale) - call MOM_write_field(unit, fields(6), G%Domain, G%CoriolisBu, scale=s_to_T_scale) + call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, scale=Z_to_m_scale) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, scale=s_to_T_scale) - call MOM_write_field(unit, fields(7), G%Domain, G%dxCv, scale=L_to_m_scale) - call MOM_write_field(unit, fields(8), G%Domain, G%dyCu, scale=L_to_m_scale) - call MOM_write_field(unit, fields(9), G%Domain, G%dxCu, scale=L_to_m_scale) - call MOM_write_field(unit, fields(10), G%Domain, G%dyCv, scale=L_to_m_scale) - call MOM_write_field(unit, fields(11), G%Domain, G%dxT, scale=L_to_m_scale) - call MOM_write_field(unit, fields(12), G%Domain, G%dyT, scale=L_to_m_scale) - call MOM_write_field(unit, fields(13), G%Domain, G%dxBu, scale=L_to_m_scale) - call MOM_write_field(unit, fields(14), G%Domain, G%dyBu, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, scale=L_to_m_scale) - call MOM_write_field(unit, fields(15), G%Domain, G%areaT, scale=L_to_m_scale**2) - call MOM_write_field(unit, fields(16), G%Domain, G%areaBu, scale=L_to_m_scale**2) + call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, scale=L_to_m_scale**2) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, scale=L_to_m_scale**2) - call MOM_write_field(unit, fields(17), G%Domain, G%dx_Cv, scale=L_to_m_scale) - call MOM_write_field(unit, fields(18), G%Domain, G%dy_Cu, scale=L_to_m_scale) - call MOM_write_field(unit, fields(19), G%Domain, G%mask2dT) + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, scale=L_to_m_scale) + call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - call MOM_write_field(unit, fields(20), G%Domain, G%Dblock_u, scale=Z_to_m_scale) - call MOM_write_field(unit, fields(21), G%Domain, G%Dopen_u, scale=Z_to_m_scale) - call MOM_write_field(unit, fields(22), G%Domain, G%Dblock_v, scale=Z_to_m_scale) - call MOM_write_field(unit, fields(23), G%Domain, G%Dopen_v, scale=Z_to_m_scale) + call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, scale=Z_to_m_scale) + call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, scale=Z_to_m_scale) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, scale=Z_to_m_scale) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=Z_to_m_scale) endif - call close_file(unit) + call close_file(IO_handle) call callTree_leave('write_ocean_geometry_file()') end subroutine write_ocean_geometry_file diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 3e745dcafd..5050b6fce3 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -190,8 +190,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call get_param(PF, mdl, "DEBUG", debug, default=.false.) call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) - new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, & - G, restart_CS) + new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G, restart_CS) just_read = .not.new_sim call get_param(PF, mdl, "INPUTDIR", inputdir, & @@ -485,8 +484,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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. - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, restart_CS) + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, restart_CS) if (present(Time_in)) Time = Time_in if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then H_rescale = GV%m_to_H / GV%m_to_H_restart From 45ce019a4cd6e233a6b3db49963364588e1b558c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Feb 2021 07:15:30 -0500 Subject: [PATCH 211/212] +Add optional scale argument to read_variable Added the new optional scale argument to the real versions of the read_variable routines. All answers are bitwise identical, but there are new optional arguments to public routines. --- src/framework/MOM_io.F90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 51253d2e20..1159ac87e1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -608,12 +608,14 @@ end subroutine read_var_sizes !> Read a real scalar variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_0d(filename, varname, var, ncid_in) +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 integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the - !! file is opened and closed within this routine. + !! 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 integer :: varid, ncid, rc character(len=256) :: hdr @@ -634,6 +636,8 @@ subroutine read_variable_0d(filename, varname, var, ncid_in) " Difficulties reading "//trim(varname)//" from "//trim(filename)) if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + + if (present(scale)) var = scale * var endif call broadcast(var, blocking=.true.) @@ -641,12 +645,14 @@ end subroutine read_variable_0d !> Read a 1-d real variable from a netCDF file with the root PE, and broadcast the !! results to all the other PEs. -subroutine read_variable_1d(filename, varname, var, ncid_in) +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 integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the - !! file is opened and closed within this routine. + !! 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 integer :: varid, ncid, rc character(len=256) :: hdr @@ -667,6 +673,10 @@ subroutine read_variable_1d(filename, varname, var, ncid_in) " Difficulties reading "//trim(varname)//" from "//trim(filename)) if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + + if (present(scale)) then ; if (scale /= 1.0) then + var(:) = scale * var(:) + endif ; endif endif call broadcast(var, size(var), blocking=.true.) From 14b1269efb0b6e2dc229d2954bd2d6d0fdd66192 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Feb 2021 07:16:40 -0500 Subject: [PATCH 212/212] +Revised the depth list type for standard I/O Revised the depth list type used in MOM_sum_output to accommodate I/O using ordinary routines, and to make the code creating, reading and writing it potentially separable from the MOM_sum_output module by avoiding the use of the MOM_sum_output control structure in most of the routines. Also changed the index 'l' to 'li' in some places to avoid having it misread as '1'. All answers are bitwise identical but there are changes in some subroutine arguments. --- src/diagnostics/MOM_sum_output.F90 | 193 +++++++++++++++-------------- 1 file changed, 100 insertions(+), 93 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 70ec9404d1..b2e0275ea8 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -53,15 +53,15 @@ module MOM_sum_output !> A list of depths and corresponding globally integrated ocean area at each !! depth and the ocean volume below each depth. type :: Depth_List - real :: depth !< A depth [Z ~> m]. - real :: area !< The cross-sectional area of the ocean at that depth [L2 ~> m2]. - real :: vol_below !< The ocean volume below that depth [Z m2 ~> m3]. + integer :: listsize !< length of the list <= niglobal*njglobal + 1 + real, allocatable, dimension(:) :: depth !< A list of depths [Z ~> m] + real, allocatable, dimension(:) :: area !< The cross-sectional area of the ocean at that depth [L2 ~> m2] + real, allocatable, dimension(:) :: vol_below !< The ocean volume below that depth [Z m2 ~> m3] end type Depth_List !> The control structure for the MOM_sum_output module type, public :: sum_output_CS ; private - type(Depth_List), pointer, dimension(:) :: DL => NULL() !< The sorted depth list. - integer :: list_size !< length of sorting vector <= niglobal*njglobal + type(Depth_List) :: DL !< The sorted depth list. integer, allocatable, dimension(:) :: lH !< This saves the entry in DL with a volume just @@ -251,9 +251,9 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & endif allocate(CS%lH(GV%ke)) - call depth_list_setup(G, GV, US, CS) + call depth_list_setup(G, GV, US, CS%DL, CS) else - CS%list_size = 0 + CS%DL%listsize = 1 endif call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & @@ -287,7 +287,8 @@ subroutine MOM_sum_output_end(CS) !! previous call to MOM_sum_output_init. if (associated(CS)) then if (CS%do_APE_calc) then - deallocate(CS%lH, CS%DL) + deallocate(CS%DL%depth, CS%DL%area, CS%DL%vol_below) + deallocate(CS%lH) endif deallocate(CS) @@ -398,8 +399,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer - integer :: l, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. - ! lbelow & labove are lower & upper limits for l + integer :: li, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. + ! 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 @@ -645,23 +646,23 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ lbelow = 1 ; volbelow = 0.0 do k=nz,1,-1 volbelow = volbelow + vol_lay(k) - if ((volbelow >= CS%DL(CS%lH(k))%vol_below) .and. & - (volbelow < CS%DL(CS%lH(k)+1)%vol_below)) then - l = CS%lH(k) + if ((volbelow >= CS%DL%vol_below(CS%lH(k))) .and. & + (volbelow < CS%DL%vol_below(CS%lH(k)+1))) then + li = CS%lH(k) else - labove=CS%list_size+1 - l = (labove + lbelow) / 2 - do while (l > lbelow) - if (volbelow < CS%DL(l)%vol_below) then ; labove = l - else ; lbelow = l ; endif - l = (labove + lbelow) / 2 + labove=CS%DL%listsize + li = (labove + lbelow) / 2 + do while (li > lbelow) + if (volbelow < CS%DL%vol_below(li)) then ; labove = li + else ; lbelow = li ; endif + li = (labove + lbelow) / 2 enddo - CS%lH(k) = l + CS%lH(k) = li endif - lbelow = l - Z_0APE(K) = CS%DL(l)%depth - (volbelow - CS%DL(l)%vol_below) / CS%DL(l)%area + lbelow = li + Z_0APE(K) = CS%DL%depth(li) - (volbelow - CS%DL%vol_below(li)) / CS%DL%area(li) enddo - Z_0APE(nz+1) = CS%DL(2)%depth + Z_0APE(nz+1) = CS%DL%depth(2) ! Calculate the Available Potential Energy integrated over each interface. With a nonlinear ! equation of state or with a bulk mixed layer this calculation is only approximate. @@ -1089,41 +1090,53 @@ end subroutine accumulate_net_input !! cross sectional areas at each depth and the volume of fluid deeper !! than each depth. This might be read from a previously created file !! or it might be created anew. (For now only new creation occurs. -subroutine depth_list_setup(G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Sum_output_CS), pointer :: CS !< The control structure returned by a - !! previous call to MOM_sum_output_init. +subroutine depth_list_setup(G, GV, US, DL, 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(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes to set up + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. ! Local variables + logical :: valid_DL_read integer :: k if (CS%read_depth_list) then if (file_exists(CS%depth_list_file)) then - call read_depth_list(G, US, CS, CS%depth_list_file) + if (CS%update_depth_list_chksum) then + call read_depth_list(G, US, DL, CS%depth_list_file, & + require_chksum=CS%require_depth_list_chksum, file_matches=valid_DL_read) + else + call read_depth_list(G, US, DL, CS%depth_list_file, require_chksum=CS%require_depth_list_chksum) + 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: "// & trim(CS%depth_list_file)//" does not exist. Creating a new file.") - call create_depth_list(G, CS) + valid_DL_read = .false. + endif - call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + if (.not.valid_DL_read) then + call create_depth_list(G, DL, CS%D_list_min_inc) + call write_depth_list(G, US, DL, CS%depth_list_file) endif else - call create_depth_list(G, CS) + call create_depth_list(G, DL, CS%D_list_min_inc) endif do k=1,GV%ke - CS%lH(k) = CS%list_size + CS%lH(k) = DL%listsize-1 enddo end subroutine depth_list_setup !> create_depth_list makes an ordered list of depths, along with the cross !! sectional areas at each depth and the volume of fluid deeper than each depth. -subroutine create_depth_list(G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS !< The control structure set up in MOM_sum_output_init, - !! in which the ordered depth list is stored. +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] + ! Local variables real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & Dlist, & !< The global list of bottom depths [Z ~> m]. @@ -1194,14 +1207,14 @@ subroutine create_depth_list(G, CS) D_list_prev = Dlist(indx2(mls)) list_size = 2 do k=mls-1,1,-1 - if (Dlist(indx2(k)) < D_list_prev-CS%D_list_min_inc) then + if (Dlist(indx2(k)) < D_list_prev-min_depth_inc) then list_size = list_size + 1 D_list_prev = Dlist(indx2(k)) endif enddo - CS%list_size = list_size - allocate(CS%DL(CS%list_size+1)) + DL%listsize = list_size+1 + allocate(DL%depth(DL%listsize), DL%area(DL%listsize), DL%vol_below(DL%listsize)) vol = 0.0 ; area = 0.0 Dprev = Dlist(indx2(mls)) @@ -1216,42 +1229,41 @@ subroutine create_depth_list(G, CS) add_to_list = .false. if ((kl == 0) .or. (k==1)) then add_to_list = .true. - elseif (Dlist(indx2(k-1)) < D_list_prev-CS%D_list_min_inc) then + elseif (Dlist(indx2(k-1)) < D_list_prev-min_depth_inc) then add_to_list = .true. D_list_prev = Dlist(indx2(k-1)) endif if (add_to_list) then kl = kl+1 - CS%DL(kl)%depth = Dlist(i) - CS%DL(kl)%area = area - CS%DL(kl)%vol_below = vol + DL%depth(kl) = Dlist(i) + DL%area(kl) = area + DL%vol_below(kl) = vol endif Dprev = Dlist(i) enddo - do while (kl < list_size) + do while (kl+1 < DL%listsize) ! I don't understand why this is needed... RWH kl = kl+1 - CS%DL(kl)%vol_below = CS%DL(kl-1)%vol_below * 1.000001 - CS%DL(kl)%area = CS%DL(kl-1)%area - CS%DL(kl)%depth = CS%DL(kl-1)%depth + DL%vol_below(kl) = DL%vol_below(kl-1) * 1.000001 + DL%area(kl) = DL%area(kl-1) + DL%depth(kl) = DL%depth(kl-1) enddo - CS%DL(CS%list_size+1)%vol_below = CS%DL(CS%list_size)%vol_below * 1000.0 - CS%DL(CS%list_size+1)%area = CS%DL(CS%list_size)%area - CS%DL(CS%list_size+1)%depth = CS%DL(CS%list_size)%depth + DL%vol_below(DL%listsize) = DL%vol_below(DL%listsize-1) * 1000.0 + DL%area(DL%listsize) = DL%area(DL%listsize-1) + DL%depth(DL%listsize) = DL%depth(DL%listsize-1) end subroutine create_depth_list !> This subroutine writes out the depth list to the specified file. -subroutine write_depth_list(G, US, CS, filename, list_size) +subroutine write_depth_list(G, US, DL, filename) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Sum_output_CS), pointer :: CS !< The control structure returned by a - !! previous call to MOM_sum_output_init. + type(Depth_List), intent(in) :: DL !< The list of depths, areas and volumes to write character(len=*), intent(in) :: filename !< The path to the depth list file to write. - integer, intent(in) :: list_size !< The size of the depth list. + ! Local variables real, allocatable :: tmp(:) integer :: ncid, dimid(1), Did, Aid, Vid, status, k @@ -1262,7 +1274,7 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (.not.is_root_pe()) return - allocate(tmp(list_size)) ; tmp(:) = 0.0 + allocate(tmp(DL%listsize)) ; tmp(:) = 0.0 status = NF90_CREATE(filename, 0, ncid) if (status /= NF90_NOERR) then @@ -1270,7 +1282,7 @@ subroutine write_depth_list(G, US, CS, filename, list_size) return endif - status = NF90_DEF_DIM(ncid, "list", list_size, dimid(1)) + status = NF90_DEF_DIM(ncid, "list", DL%listsize, dimid(1)) if (status /= NF90_NOERR) call MOM_error(WARNING, & trim(filename)//trim(NF90_STRERROR(status))) @@ -1317,17 +1329,17 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & trim(filename)//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = US%Z_to_m*CS%DL(k)%depth ; enddo + do k=1,DL%listsize ; tmp(k) = US%Z_to_m*DL%depth(k) ; enddo status = NF90_PUT_VAR(ncid, Did, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & trim(filename)//" depth "//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = US%L_to_m**2*CS%DL(k)%area ; enddo + do k=1,DL%listsize ; tmp(k) = US%L_to_m**2*DL%area(k) ; enddo status = NF90_PUT_VAR(ncid, Aid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & trim(filename)//" area "//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = US%Z_to_m*US%L_to_m**2*CS%DL(k)%vol_below ; enddo + do k=1,DL%listsize ; tmp(k) = US%Z_to_m*US%L_to_m**2*DL%vol_below(k) ; enddo status = NF90_PUT_VAR(ncid, Vid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) @@ -1338,14 +1350,18 @@ subroutine write_depth_list(G, US, CS, filename, list_size) end subroutine write_depth_list -!> This subroutine reads in the depth list to the specified file -!! and allocates and sets up CS%DL and CS%list_size . -subroutine read_depth_list(G, US, CS, filename) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Sum_output_CS), pointer :: CS !< The control structure returned by a - !! previous call to MOM_sum_output_init. - character(len=*), intent(in) :: filename !< The path to the depth list file to read. +!> This subroutine reads in the depth list from the specified file +!! and allocates the memory within and sets up DL. +subroutine read_depth_list(G, US, DL, filename, require_chksum, file_matches) + 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(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes + character(len=*), intent(in) :: filename !< The path to the depth list file to read. + logical, intent(in) :: require_chksum !< If true, missing or mismatched depth + !! and area checksums result in a fatal error. + logical, optional, intent(out) :: file_matches !< If present, this indicates whether the file + !! has been read with matching depth and area checksums + ! Local variables character(len=240) :: var_msg real, allocatable :: tmp(:) @@ -1359,30 +1375,27 @@ subroutine read_depth_list(G, US, CS, filename) call read_attribute(filename, area_chksum_attr, area_file_chksum, found=area_att_found) if ((.not.depth_att_found) .or. (.not.area_att_found)) then - var_msg = trim(CS%depth_list_file) // " checksums are missing;" - if (CS%require_depth_list_chksum) then + var_msg = trim(filename) // " checksums are missing;" + if (require_chksum) then call MOM_error(FATAL, trim(var_msg) // " aborting.") - elseif (CS%update_depth_list_chksum) then + elseif (present(file_matches)) then call MOM_error(WARNING, trim(var_msg) // " updating file.") - call create_depth_list(G, CS) - call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + file_matches = .false. return else - call MOM_error(WARNING, & - trim(var_msg) // " some diagnostics may not be reproducible.") + call MOM_error(WARNING, trim(var_msg) // " some diagnostics may not be reproducible.") endif else call get_depth_list_checksums(G, depth_grid_chksum, area_grid_chksum) if ((trim(depth_grid_chksum) /= trim(depth_file_chksum)) .or. & (trim(area_grid_chksum) /= trim(area_file_chksum)) ) then - var_msg = trim(CS%depth_list_file) // " checksums do not match;" - if (CS%require_depth_list_chksum) then + var_msg = trim(filename) // " checksums do not match;" + if (require_chksum) then call MOM_error(FATAL, trim(var_msg) // " aborting.") - elseif (CS%update_depth_list_chksum) then + elseif (present(file_matches)) then call MOM_error(WARNING, trim(var_msg) // " updating file.") - call create_depth_list(G, CS) - call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + file_matches = .false. return else call MOM_error(WARNING, trim(var_msg) // " some diagnostics may not be reproducible.") @@ -1398,20 +1411,14 @@ subroutine read_depth_list(G, US, CS, filename) trim(filename)//" has too many or too few dimensions.") list_size = sizes(1) - CS%list_size = list_size-1 - allocate(CS%DL(list_size)) - allocate(tmp(list_size)) - - call read_variable(filename, "depth", tmp) - do k=1,list_size ; CS%DL(k)%depth = US%m_to_Z*tmp(k) ; enddo - - call read_variable(filename, "area", tmp) - do k=1,list_size ; CS%DL(k)%area = US%m_to_L**2*tmp(k) ; enddo + DL%listsize = list_size + allocate(DL%depth(list_size), DL%area(list_size), DL%vol_below(list_size)) - call read_variable(filename, "vol_below", tmp) - do k=1,list_size ; CS%DL(k)%vol_below = US%m_to_Z*US%m_to_L**2*tmp(k) ; enddo + call read_variable(filename, "depth", DL%depth, scale=US%m_to_Z) + call read_variable(filename, "area", DL%area, scale=US%m_to_L**2) + call read_variable(filename, "vol_below", DL%vol_below, scale=US%m_to_Z*US%m_to_L**2) - deallocate(tmp) + if (present(file_matches)) file_matches = .true. end subroutine read_depth_list