From 0add693a8970bf206fa6879915b56c3170ae33da Mon Sep 17 00:00:00 2001 From: Philip Pegion Date: Tue, 5 May 2020 09:41:38 -0500 Subject: [PATCH 001/155] additions for stochastic physics and ePBL perts --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 + src/core/MOM.F90 | 39 +++++++++--- src/core/MOM_forcing_type.F90 | 19 ++++-- src/diagnostics/MOM_diagnostics.F90 | 22 +++++-- src/framework/MOM_domains.F90 | 59 ++++--------------- .../vertical/MOM_energetic_PBL.F90 | 2 +- 6 files changed, 79 insertions(+), 64 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index c704214930..10add0f8d0 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -315,6 +315,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + print*,'allocate fluxes%t_rp' + call safe_alloc_ptr(fluxes%t_rp,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then fluxes%p_surf_SSH => fluxes%p_surf else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c36c0545e1..ae535dcbeb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -30,6 +30,7 @@ module MOM 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 use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners +use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -154,8 +155,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, initialize_ice_shelf -use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end +use stochastic_physics, only : init_stochastic_physics_ocn,run_stochastic_physics_ocn implicit none ; private @@ -248,6 +248,8 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode + logical :: do_stochy = .false. + !< If true, call stochastic physics pattern generator type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [T ~> s] @@ -826,6 +828,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + print*,'calling run_stochastic_physics_ocn',CS%do_stochy + if (CS%do_stochy) call run_stochastic_physics_ocn(forces%t_rp) call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & @@ -978,7 +982,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & - sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) + sfc_state, CS%tv, ssh, fluxes%t_rp, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1811,10 +1815,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - real :: conv2watt ! A conversion factor from temperature fluxes to heat - ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] - real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] - real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors + integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer :: num_procs +! model + integer :: me ! my pe + integer :: master ! root pe + real :: conv2watt, conv2salt character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -2490,6 +2496,25 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif + ! Shift from using the temporary dynamic grid type to using the final + ! (potentially static) ocean-specific grid type. + ! The next line would be needed if G%Domain had not already been init'd above: + ! call clone_MOM_domain(dG%Domain, G%Domain) + call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG, G, US) + call destroy_dyn_horgrid(dG) + + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist) + me=PE_here() + master=root_PE() + + !call init_stochastic_physics_ocn(CS%dt_therm,G,me,master,pelist,CS%do_stochy) + print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) + call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,CS%do_stochy) + print*,'back from init_stochastic_physics_ocn',CS%do_stochy + ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3248c09fa4..e11b6a39ce 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,6 +145,8 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. + real, pointer, dimension(:,:) :: t_rp => NULL() + !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -248,10 +250,10 @@ module MOM_forcing_type !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, !! and is exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: & - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at - !! u-points [L4 Z-1 T-1 ~> m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at - !! v-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] + real, pointer, dimension(:,:) :: t_rp => NULL() + !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2126,6 +2128,12 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres + if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then + do j=js,je ; do i=is,ie + fluxes%t_rp(i,j) = forces%t_rp(i,j) + enddo ; enddo + endif + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) @@ -3088,6 +3096,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) + call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3252,6 +3261,7 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) + if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3280,6 +3290,7 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) + if (associated(forces%t_rp)) deallocate(forces%t_rp) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8d667503d7..fca2ed869f 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,7 +139,9 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - !>@} +! stochastic pattern + integer :: id_t_rp = -1 + !!@} end type surface_diag_IDs @@ -1277,7 +1279,7 @@ end subroutine post_surface_dyn_diags !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & - ssh, ssh_ibc) + ssh, t_rp, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1286,8 +1288,10 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> s]. type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< Time mean surface height without corrections - !! for ice displacement [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: t_rp!< random pattern for stochastic proceeses real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] @@ -1414,6 +1418,11 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif + if (IDs%id_t_rp > 0) then + !call post_data(IDs%id_t_rp, t_rp, diag, mask=G%mask2dT) + call post_data(IDs%id_t_rp, t_rp, diag) + endif + call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) end subroutine post_surface_thermo_diags @@ -1901,8 +1910,9 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', & - 'W m-2', conversion=US%QRZ_T_to_W_m2) + 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') + IDs%id_t_rp = register_diag_field('ocean_model', 'random_pattern', diag%axesT1, Time, & + 'random pattern for stochastics', 'None') end subroutine register_surface_diags diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 0cdcc455fc..acbc1ccaea 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,56 +3,23 @@ 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_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 : get_domain_extent, get_domain_components, same_domain -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 -use MOM_domain_infra, only : start_group_pass, complete_group_pass -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 -use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io_infra, only : file_exists +use MOM_coms, only : PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end, Get_PElist +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_string_functions, only : slasher implicit none ; private -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 -public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! Domain query routines -public :: get_domain_extent, get_domain_components, get_global_shape, same_domain -public :: PE_here, root_PE, num_PEs -! Blocks are not actively used in MOM6, so this routine could be deprecated. -public :: compute_block_extent -! 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 :: 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 -public :: CORNER, CENTER, NORTH_FACE, EAST_FACE -!> These encoding constants indicate communication patterns. In practice they can be added. +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 :: pass_var, pass_vector, PE_here, root_PE, num_PEs, Get_PElist +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, CORNER, CENTER 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. diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..c9ae6e43ed 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -401,7 +401,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j) + u_star = fluxes%ustar(i,j)*(fluxes%t_rp(i,j)) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then From a534541c52b5b319c6f07df4b01992b3f4c96bc7 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 2 Dec 2020 15:35:05 +0000 Subject: [PATCH 002/155] cleanup of code and enhancement of ePBL perts --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 - src/core/MOM.F90 | 28 +-- src/core/MOM_forcing_type.F90 | 43 +++-- src/diagnostics/MOM_diagnostics.F90 | 16 +- .../vertical/MOM_diabatic_driver.F90 | 174 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 62 ++++--- 6 files changed, 172 insertions(+), 153 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 10add0f8d0..c704214930 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -315,8 +315,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) - print*,'allocate fluxes%t_rp' - call safe_alloc_ptr(fluxes%t_rp,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then fluxes%p_surf_SSH => fluxes%p_surf else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ae535dcbeb..1a5b27a462 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -155,7 +155,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 stochastic_physics, only : init_stochastic_physics_ocn,run_stochastic_physics_ocn +use stochastic_physics, only : init_stochastic_physics_ocn implicit none ; private @@ -828,9 +828,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif - print*,'calling run_stochastic_physics_ocn',CS%do_stochy - if (CS%do_stochy) call run_stochastic_physics_ocn(forces%t_rp) - call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & Time_local, Waves=Waves) @@ -982,7 +979,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & - sfc_state, CS%tv, ssh, fluxes%t_rp, CS%ave_ssh_ibc) + sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) + !sfc_state_diag, CS%tv, ssh,fluxes%t_rp,fluxes%sppt_wts, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1809,6 +1807,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic ! time step needs to be updated before it is used. logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. + logical :: do_epbl,do_sppt integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. @@ -1816,7 +1815,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: num_procs + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs,iret ! model integer :: me ! my pe integer :: master ! root pe @@ -2506,14 +2506,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & num_procs=num_PEs() allocate(pelist(num_procs)) - call Get_PElist(pelist) + call Get_PElist(pelist,commID = mom_comm) me=PE_here() master=root_PE() - !call init_stochastic_physics_ocn(CS%dt_therm,G,me,master,pelist,CS%do_stochy) - print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,CS%do_stochy) - print*,'back from init_stochastic_physics_ocn',CS%do_stochy + !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) + do_epbl=.false. + do_sppt=.false. + call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) + if (do_sppt .eq. .true.) CS%do_stochy=.true. + if (do_epbl .eq. .true.) CS%do_stochy=.true. + !print*,'back from init_stochastic_physics_ocn',CS%do_stochy ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then @@ -2969,6 +2972,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! call fix_restart_scaling(GV) ! call fix_restart_unit_scaling(US) + CS%diabatic_CSp%do_epbl=do_epbl + CS%diabatic_CSp%do_sppt=do_sppt + call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index e11b6a39ce..c363d72f09 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,8 +145,10 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. - real, pointer, dimension(:,:) :: t_rp => NULL() - !< random pattern at t-points +! real, pointer, dimension(:,:) :: t_rp => NULL() +! !< random pattern at t-points +! real, pointer, dimension(:,:) :: sppt_wts => NULL() +! !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -250,10 +252,14 @@ module MOM_forcing_type !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, !! and is exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: & - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] - real, pointer, dimension(:,:) :: t_rp => NULL() - !< random pattern at t-points + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! u-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! v-points [L4 Z-1 T-1 ~> m3 s-1] +! real, pointer, dimension(:,:) :: t_rp => NULL() +! !< random pattern at t-points +! real, pointer, dimension(:,:) :: sppt_wts => NULL() +! !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2128,11 +2134,17 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres - if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then - do j=js,je ; do i=is,ie - fluxes%t_rp(i,j) = forces%t_rp(i,j) - enddo ; enddo - endif +! if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then +! do j=js,je ; do i=is,ie +! fluxes%t_rp(i,j) = forces%t_rp(i,j) +! enddo ; enddo +! endif +! +! if (associated(forces%sppt_wts) .and. associated(fluxes%sppt_wts)) then +! do j=js,je ; do i=is,ie +! fluxes%sppt_wts(i,j) = forces%sppt_wts(i,j) +! enddo ; enddo +! endif if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie @@ -3096,7 +3108,8 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) - call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) +! call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) +! call myAlloc(forces%sppt_wts,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3261,7 +3274,8 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) - if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) +! if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) +! if (associated(fluxes%sppt_wts)) deallocate(fluxes%sppt_wts) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3290,7 +3304,8 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) - if (associated(forces%t_rp)) deallocate(forces%t_rp) +! if (associated(forces%t_rp)) deallocate(forces%t_rp) +! if (associated(forces%sppt_wts)) deallocate(forces%sppt_wts) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index fca2ed869f..b60093dce5 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,8 +139,6 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 -! stochastic pattern - integer :: id_t_rp = -1 !!@} end type surface_diag_IDs @@ -1279,7 +1277,7 @@ end subroutine post_surface_dyn_diags !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & - ssh, t_rp, ssh_ibc) + ssh, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1290,8 +1288,6 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: t_rp!< random pattern for stochastic proceeses real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] @@ -1418,11 +1414,6 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif - if (IDs%id_t_rp > 0) then - !call post_data(IDs%id_t_rp, t_rp, diag, mask=G%mask2dT) - call post_data(IDs%id_t_rp, t_rp, diag) - endif - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) end subroutine post_surface_thermo_diags @@ -1910,9 +1901,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - IDs%id_t_rp = register_diag_field('ocean_model', 'random_pattern', diag%axesT1, Time, & - 'random pattern for stochastics', 'None') + 'Heat flux into ocean from geothermal or other internal sources', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) end subroutine register_surface_diags diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5eaca3c275..c44ebba5b3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,7 +69,8 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS -use MOM_stochastics, only : stochastic_CS +use stochastic_physics, only : run_stochastic_physics_ocn + implicit none ; private @@ -175,20 +176,15 @@ module MOM_diabatic_driver real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds - integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic - integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 - integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 - integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 - ! These are handles to diagnostics related to the mixed layer properties. - integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 - - ! These are handles to diatgnostics that are only available in non-ALE layered mode. - integer :: id_wd = -1 - integer :: id_dudt_dia = -1, id_dvdt_dia = -1 - integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 + integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) + integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) + integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_ea_t = -1, id_eb_t = -1 + integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 + integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 + integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_subMLN2 = -1, id_brine_lay = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -220,6 +216,10 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics + logical,public :: do_epbl = .false. !< If true pertrub u_start in ePBL calculation + logical,public :: do_sppt = .false. !< If true perturb all physics tendenceies in MOM_diabatic_driver + real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil + real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module @@ -303,31 +303,36 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics + real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts + real, dimension(SZI_(G),SZJ_(G),2) :: t_rp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT + real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT if (G%ke == 1) return - ! save copy of the date for SPPT if active - if (stoch_CS%do_sppt) then - allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) - - if (stoch_CS%id_sppt_wts > 0) then - call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) - endif + ! save copy of the date for SPPT + if (CS%do_sppt) then + h_in=h + t_in=tv%T + s_in=tv%S + endif + call run_stochastic_physics_ocn(t_rp,sppt_wts) + !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) + !print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + if (CS%id_t_rp1 > 0) then + call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) + endif + if (CS%id_t_rp2 > 0) then + call post_data(CS%id_t_rp2, t_rp(:,:,2), CS%diag) + endif + if (CS%id_sppt_wts > 0) then + call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) endif - if (GV%ke == 1) return - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") @@ -411,11 +416,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) + call diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -481,55 +486,53 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stoch_CS%do_sppt) then - ! perturb diabatic tendecies + if (CS%do_sppt) then do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) if (h_pert > GV%Angstrom_H) then - h(i,j,k) = h_pert + h(i,j,k)=h_pert else - h(i,j,k) = GV%Angstrom_H + h(i,j,k)=GV%Angstrom_H endif - tv%T(i,j,k) = t_pert + tv%T(i,j,k)=t_pert if (s_pert > 0.0) then - tv%S(i,j,k) = s_pert + tv%S(i,j,k)=s_pert endif enddo enddo enddo - deallocate(h_in) - deallocate(t_in) - deallocate(s_in) endif end subroutine diabatic +end subroutine diabatic + !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -837,8 +840,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -1100,22 +1103,22 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -1374,8 +1377,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -3138,11 +3141,16 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & - call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) - if ((CS%id_dvdt_dia > 0) .or. (CS%id_hf_dvdt_dia_2d > 0)) & - call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) - endif + CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & + 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & + 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + 'random pattern1 for stochastics', 'None') + CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + 'random pattern2 for stochastics', 'None') + CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & + 'random pattern for sppt', 'None') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index c9ae6e43ed..ffa942b03a 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -165,6 +165,7 @@ module MOM_energetic_PBL !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in !! upward or downward passes. + logical :: do_epbl type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the !! timing of diagnostic output. @@ -244,8 +245,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, US, CS, & + dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & + dT_expected, dS_expected, Waves ) 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 @@ -277,8 +279,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + !! [Z2 s-1 ~> m2 s-1]. + type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous + !! call to mixedlayer_init. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: t_rp !< random pattern to perturb wind real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -401,7 +406,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j)*(fluxes%t_rp(i,j)) + !print*,'PJP EPBL',minval(t_rp),maxval(t_rp) + u_star = fluxes%ustar(i,j)!*t_rp(i,j) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then @@ -423,16 +429,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, Waves, G, i, j, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) - else - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, Waves, G, i, j) - endif + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + + ! applly stochastic perturbation to TKE generation ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -500,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - Waves, G, i, j, epbl1_wt, epbl2_wt) + t_rp1,t_rp2, dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -537,12 +538,16 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation - integer, intent(in) :: i !< The i-index to work on (used for Waves) - integer, intent(in) :: j !< The i-index to work on (used for Waves) + real, intent(in) :: t_rp1 !< random value to perturb TKE production + real, intent(in) :: t_rp2 !< random value to perturb TKE production + real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less + !! than dt if there are two calls to mixedlayer [T ~> s]. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Wave CS for Langmuir turbulence + type(ocean_grid_type), & + optional, intent(inout) :: G !< The ocean's grid structure. + integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) + integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) ! This subroutine determines the diffusivities in a single column from the integrated energetics ! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes @@ -831,8 +836,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE in the UFS - if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt + ! stochastically pertrub mech_TKE + mech_TKE=mech_TKE*t_rp1 if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -914,12 +919,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & - eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) - else - mech_TKE = mech_TKE * exp_kh - endif + !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + eCD%dTKE_mech_decay = exp_kh + mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From a0e5b56afaeb70957d91f3ce2795ed40fda3542d Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:03:36 -0700 Subject: [PATCH 003/155] Update MOM_diabatic_driver.F90 remove conflict with dev/emc --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index c44ebba5b3..95ec33e91a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_brine_lay = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From c48a46ae01cf094c919ca8aae9971a0feea09c4d Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:05:28 -0700 Subject: [PATCH 004/155] Update MOM_diabatic_driver.F90 further resolve conflict --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 95ec33e91a..14856b4415 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From 5f6973b4d77d3829fd51e75d333d153dd69c7ca1 Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:06:52 -0700 Subject: [PATCH 005/155] Update MOM_diabatic_driver.F90 put id_sppt_wts, etc back. --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 14856b4415..95ec33e91a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From 36ce2d10807e8b43d3a1588e712d74f9cf42dd75 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 14 Dec 2020 15:47:16 +0000 Subject: [PATCH 006/155] add stochy_restart writing to mom_cap --- config_src/drivers/nuopc_cap/mom_cap.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 174a659f12..0434103b5a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,6 +97,7 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM +use get_stochy_pattern_mod, only: write_stoch_restart_ocn !$use omp_lib , only : omp_set_num_threads @@ -1749,9 +1750,17 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname, & - stoch_restartname=stoch_restartname) + call ocean_model_restart(ocean_state, restartname=restartname) + ! write stochastic physics restart file if active + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"ocn_stoch.res.nc") + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + "oc_stoch.res.", year, month, day, hour, minute, seconds,".nc" + endif + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + call write_stoch_restart_ocn('RESTART/'//trim(timestamp)//'.ocn_stoch.res.nc') endif if (is_root_pe()) then From becb4420e0eaa6d32511ba7efdedd96d2450632b Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 22 Dec 2020 18:40:13 +0000 Subject: [PATCH 007/155] additions for stochy restarts --- config_src/drivers/nuopc_cap/mom_cap.F90 | 11 ++++++++--- config_src/drivers/solo_driver/MOM_driver.F90 | 16 ++++++++++++++++ src/core/MOM.F90 | 14 +++++++------- .../vertical/MOM_diabatic_driver.F90 | 16 +++++++++++++--- .../vertical/MOM_energetic_PBL.F90 | 19 ++++++++++--------- 5 files changed, 54 insertions(+), 22 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 0434103b5a..b298270d17 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,7 +97,9 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM +#ifdef UFS use get_stochy_pattern_mod, only: write_stoch_restart_ocn +#endif !$use omp_lib , only : omp_set_num_threads @@ -1753,14 +1755,17 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname) ! write stochastic physics restart file if active +#ifdef UFS if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc") + write(restartname,'(A)')"ocn_stoch.res.nc" else write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "oc_stoch.res.", year, month, day, hour, minute, seconds,".nc" + "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - call write_stoch_restart_ocn('RESTART/'//trim(timestamp)//'.ocn_stoch.res.nc') + if (is_root_pe()) print*,'calling write_stoch_restart_ocn ',trim(restartname) + call write_stoch_restart_ocn('RESTART/'//trim(restartname)) +#endif endif if (is_root_pe()) then diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 1b88f1ce36..eb6f64710d 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -69,6 +69,22 @@ program MOM_main use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + 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 + use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart +! , add_shelf_flux_forcing, add_shelf_flux_IOB + + 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 +#ifdef UFS + use get_stochy_pattern_mod, only: write_stoch_restart_ocn +#endif + implicit none #include diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1a5b27a462..e864b9f481 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -155,7 +155,9 @@ 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 +#ifdef UFS use stochastic_physics, only : init_stochastic_physics_ocn +#endif implicit none ; private @@ -248,8 +250,6 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode - logical :: do_stochy = .false. - !< If true, call stochastic physics pattern generator type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [T ~> s] @@ -2504,6 +2504,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call copy_dyngrid_to_MOM_grid(dG, G, US) call destroy_dyn_horgrid(dG) + do_epbl=.false. + do_sppt=.false. +#ifdef UFS num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) @@ -2511,12 +2514,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & master=root_PE() !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - do_epbl=.false. - do_sppt=.false. + if (master) print*,'about to call init_stochastic_physics' call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) - if (do_sppt .eq. .true.) CS%do_stochy=.true. - if (do_epbl .eq. .true.) CS%do_stochy=.true. - !print*,'back from init_stochastic_physics_ocn',CS%do_stochy +#endif ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 95ec33e91a..bef2e1c584 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,7 +69,9 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS +#ifdef UFS use stochastic_physics, only : run_stochastic_physics_ocn +#endif implicit none ; private @@ -305,23 +307,28 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts real, dimension(SZI_(G),SZJ_(G),2) :: t_rp +#ifdef UFS real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT +#endif if (G%ke == 1) return +#ifdef UFS ! save copy of the date for SPPT if (CS%do_sppt) then h_in=h t_in=tv%T s_in=tv%S endif + print*,'calling run_stochastic_physics' call run_stochastic_physics_ocn(t_rp,sppt_wts) !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) - !print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + print*,'in diabatic',CS%do_sppt,minval(t_rp),maxval(t_rp) if (CS%id_t_rp1 > 0) then call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) endif @@ -331,6 +338,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_sppt_wts > 0) then call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) endif +#endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -486,6 +494,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) +#ifdef UFS if (CS%do_sppt) then do k=1,nz do j=js,je @@ -509,6 +518,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo endif +#endif end subroutine diabatic @@ -840,7 +850,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -1377,7 +1387,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index ffa942b03a..4f7fff1a05 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -245,7 +245,7 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & dT_expected, dS_expected, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -284,6 +284,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, !! call to mixedlayer_init. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: t_rp !< random pattern to perturb wind + logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -406,8 +407,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - !print*,'PJP EPBL',minval(t_rp),maxval(t_rp) - u_star = fluxes%ustar(i,j)!*t_rp(i,j) + u_star = fluxes%ustar(i,j) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then @@ -431,7 +431,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) ! applly stochastic perturbation to TKE generation @@ -501,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - t_rp1,t_rp2, dt_diag, Waves, G, i, j) + t_rp1,t_rp2, stoch_epbl, dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -539,7 +539,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. real, intent(in) :: t_rp1 !< random value to perturb TKE production - real, intent(in) :: t_rp2 !< random value to perturb TKE production + real, intent(in) :: t_rp2 !< random value to perturb TKE dissipation + logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less !! than dt if there are two calls to mixedlayer [T ~> s]. type(wave_parameters_CS), & @@ -836,8 +837,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE - mech_TKE=mech_TKE*t_rp1 + ! stochastically pertrub mech_TKE in the UFS + if (stoch_epbl) mech_TKE=mech_TKE*t_rp1 if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -921,7 +922,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%TKE_diagnostics) & !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag eCD%dTKE_mech_decay = exp_kh - mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 0c48bfc6a4aff73da944a7eecf6e1e7d57db20cd Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 23 Dec 2020 21:46:27 +0000 Subject: [PATCH 008/155] clean up debug statements --- config_src/drivers/nuopc_cap/mom_cap.F90 | 1 - config_src/drivers/solo_driver/MOM_driver.F90 | 3 --- src/core/MOM.F90 | 2 -- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ---- 4 files changed, 10 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b298270d17..8778df067a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1763,7 +1763,6 @@ subroutine ModelAdvance(gcomp, rc) "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - if (is_root_pe()) print*,'calling write_stoch_restart_ocn ',trim(restartname) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) #endif endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index eb6f64710d..5bfe0bb8a2 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -81,9 +81,6 @@ program MOM_main 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 -#ifdef UFS - use get_stochy_pattern_mod, only: write_stoch_restart_ocn -#endif implicit none diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e864b9f481..058c285133 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2513,8 +2513,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & me=PE_here() master=root_PE() - !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - if (master) print*,'about to call init_stochastic_physics' call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) #endif diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index bef2e1c584..01ae5811af 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -324,11 +324,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & t_in=tv%T s_in=tv%S endif - print*,'calling run_stochastic_physics' call run_stochastic_physics_ocn(t_rp,sppt_wts) - !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) - print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) - print*,'in diabatic',CS%do_sppt,minval(t_rp),maxval(t_rp) if (CS%id_t_rp1 > 0) then call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) endif From 49111ff9fef60d180f33272e19acf32da4e800ed Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 6 Jan 2021 15:35:18 +0000 Subject: [PATCH 009/155] clean up code --- src/core/MOM.F90 | 7 +++-- src/core/MOM_forcing_type.F90 | 26 ------------------- src/diagnostics/MOM_diagnostics.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 6 ++--- 4 files changed, 6 insertions(+), 35 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 058c285133..0c5a1a9788 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -980,7 +980,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) - !sfc_state_diag, CS%tv, ssh,fluxes%t_rp,fluxes%sppt_wts, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1815,9 +1814,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs,iret -! model + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs ! number of processors to pass to stochastic physics + integer :: iret ! return code from stochastic physics integer :: me ! my pe integer :: master ! root pe real :: conv2watt, conv2salt diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c363d72f09..3248c09fa4 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,10 +145,6 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. -! real, pointer, dimension(:,:) :: t_rp => NULL() -! !< random pattern at t-points -! real, pointer, dimension(:,:) :: sppt_wts => NULL() -! !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -256,10 +252,6 @@ module MOM_forcing_type !! u-points [L4 Z-1 T-1 ~> m3 s-1] rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at !! v-points [L4 Z-1 T-1 ~> m3 s-1] -! real, pointer, dimension(:,:) :: t_rp => NULL() -! !< random pattern at t-points -! real, pointer, dimension(:,:) :: sppt_wts => NULL() -! !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2134,18 +2126,6 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres -! if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then -! do j=js,je ; do i=is,ie -! fluxes%t_rp(i,j) = forces%t_rp(i,j) -! enddo ; enddo -! endif -! -! if (associated(forces%sppt_wts) .and. associated(fluxes%sppt_wts)) then -! do j=js,je ; do i=is,ie -! fluxes%sppt_wts(i,j) = forces%sppt_wts(i,j) -! enddo ; enddo -! endif - if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) @@ -3108,8 +3088,6 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) -! call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) -! call myAlloc(forces%sppt_wts,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3274,8 +3252,6 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) -! if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) -! if (associated(fluxes%sppt_wts)) deallocate(fluxes%sppt_wts) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3304,8 +3280,6 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) -! if (associated(forces%t_rp)) deallocate(forces%t_rp) -! if (associated(forces%sppt_wts)) deallocate(forces%sppt_wts) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index b60093dce5..e0b0d4469b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,7 +139,7 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - !!@} + !>@} end type surface_diag_IDs diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 4f7fff1a05..85dc52dd0e 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -433,8 +433,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) - ! applly stochastic perturbation to TKE generation - ! Copy the diffusivities to a 2-d array. do K=1,nz+1 Kd_2d(i,K) = Kd(K) @@ -920,8 +918,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & - !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - eCD%dTKE_mech_decay = exp_kh + eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + mech_TKE = mech_TKE * exp_kh if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute From 15dde3622ae82a7c95ba6f62e34fbad976bfb7c9 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Thu, 7 Jan 2021 15:42:13 +0000 Subject: [PATCH 010/155] fix non stochastic ePBL calculation --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 85dc52dd0e..1cf089d5ed 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -919,8 +919,11 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - mech_TKE = mech_TKE * exp_kh - if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stoch_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + else + mech_TKE = mech_TKE * exp_kh + endif ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 58f1fe98fc397abc4b6418b592b91575ae50a351 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 29 Jan 2021 19:40:10 +0000 Subject: [PATCH 011/155] re-write of stochastic code to remove CPP directives --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 15 +-- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 15 +-- config_src/drivers/nuopc_cap/mom_cap.F90 | 4 - .../nuopc_cap/mom_ocean_model_nuopc.F90 | 62 ++++++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 14 +-- src/core/MOM.F90 | 48 +++------- src/core/MOM_variables.F90 | 7 ++ .../vertical/MOM_diabatic_driver.F90 | 93 +++++++------------ .../vertical/MOM_energetic_PBL.F90 | 79 ++++++++-------- 9 files changed, 158 insertions(+), 179 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 97fb869ad4..6292c32469 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -50,7 +50,7 @@ module ocean_model_mod use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -186,6 +186,7 @@ module ocean_model_mod !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -576,12 +577,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -603,16 +604,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -629,7 +630,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. Time1 = Time1 - real_to_time(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 3bd0e1e28d..4a4f6eee05 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -47,7 +47,7 @@ module MOM_ocean_model_mct use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -187,6 +187,7 @@ module MOM_ocean_model_mct !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -586,12 +587,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -615,16 +616,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -641,7 +642,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 8778df067a..3de56c0511 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,9 +97,7 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -#ifdef UFS use get_stochy_pattern_mod, only: write_stoch_restart_ocn -#endif !$use omp_lib , only : omp_set_num_threads @@ -1755,7 +1753,6 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname) ! write stochastic physics restart file if active -#ifdef UFS if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then write(restartname,'(A)')"ocn_stoch.res.nc" else @@ -1764,7 +1761,6 @@ subroutine ModelAdvance(gcomp, rc) endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) -#endif endif if (is_root_pe()) then diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 448f23140e..290e6b30df 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -43,7 +43,7 @@ module MOM_ocean_model_nuopc use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -62,8 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use get_stochy_pattern_mod, only : write_stoch_restart_ocn -use iso_fortran_env, only : int64 +use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs +use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -194,6 +194,7 @@ module MOM_ocean_model_nuopc !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -255,9 +256,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot !< If true, allocate melt_potential array - logical :: use_CFC !< If true, allocated arrays for surface CFCs. - + logical :: use_melt_pot!< If true, allocate melt_potential array +! stochastic physics + integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs ! number of processors to pass to stochastic physics + integer :: iret ! return code from stochastic physics + integer :: me ! my pe + integer :: master ! root pe ! This include declares and sets the variable "version". #include "version_variable.h" @@ -429,19 +435,21 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) -! get number of processors and PE list for stocasthci physics initialization - call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & - "If true, then stochastically perturb the thermodynamic "//& - "tendencies of T,S, and h. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) - call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & - "If true, then stochastically perturb the kinetic energy "//& - "production and dissipation terms. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + me=PE_here() + master=root_PE() + + call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& + OS%stochastics%pert_epbl,OS%stochastics%do_sppt,master,mom_comm,iret) + print*,'after init_stochastic_physics_ocn',OS%stochastics%pert_epbl,OS%stochastics%do_sppt + if (OS%stochastics%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%stochastics%pert_epbl) then + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -613,17 +621,23 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time +! update stochastic physics patterns before running next time-step + print*,'before call to stoch',OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl + if (OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl ) then + call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) + endif + if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -646,16 +660,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -672,7 +686,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 5bfe0bb8a2..ee5e92e0f4 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -62,7 +62,7 @@ program MOM_main 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_variables, only : surface, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves @@ -91,6 +91,8 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes + type(stochastic_pattern) :: stochastics !< A structure containing pointers to + ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state @@ -487,7 +489,7 @@ program MOM_main if (offline_tracer_mode) then call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, stochastics, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -500,16 +502,16 @@ program MOM_main if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) @@ -518,7 +520,7 @@ program MOM_main ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & Time2 = Time2 - real_to_time(dtdia - dt_dyn) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) n_last_thermo = n diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0c5a1a9788..50e58b8a63 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -30,7 +30,6 @@ module MOM 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 use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners -use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -133,7 +132,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state +use MOM_variables, only : rotate_surface_state,stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -155,9 +154,6 @@ 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 -#ifdef UFS -use stochastic_physics, only : init_stochastic_physics_ocn -#endif implicit none ; private @@ -455,13 +451,14 @@ module MOM !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. -subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & +subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & end_cycle, cycle_length, reset_therm) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state + type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM @@ -770,8 +767,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - end_time_thermo, .true., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & + dtdia, end_time_thermo, .true., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -871,8 +868,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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, & - Time_local, .false., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & + dtdia, Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1304,8 +1301,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & - Time_end_thermo, update_BBL, Waves) +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & + dtdia, Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1318,6 +1315,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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 + type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. @@ -1393,8 +1391,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) + call diabatic(u, v, h, tv, CS%Hml, fluxes, stochastics, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1806,19 +1804,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic ! time step needs to be updated before it is used. logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. - logical :: do_epbl,do_sppt integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs ! number of processors to pass to stochastic physics - integer :: iret ! return code from stochastic physics - integer :: me ! my pe - integer :: master ! root pe real :: conv2watt, conv2salt character(len=48) :: flux_units, S_flux_units @@ -2503,18 +2494,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call copy_dyngrid_to_MOM_grid(dG, G, US) call destroy_dyn_horgrid(dG) - do_epbl=.false. - do_sppt=.false. -#ifdef UFS - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - me=PE_here() - master=root_PE() - - call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) -#endif - ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) @@ -2969,9 +2948,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! call fix_restart_scaling(GV) ! call fix_restart_unit_scaling(US) - CS%diabatic_CSp%do_epbl=do_epbl - CS%diabatic_CSp%do_sppt=do_sppt - call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a9bf6c3dcf..4020721075 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -276,6 +276,13 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. +type, public :: stochastic_pattern + logical :: do_sppt = .false. + logical :: pert_epbl = .false. + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation + real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation +end type stochastic_pattern type, public :: BT_cont_type real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport !! drawing from locations far to the east [H L ~> m2 or kg m-1]. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 01ae5811af..df4dd4c453 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -65,13 +65,10 @@ module MOM_diabatic_driver use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs -use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d +use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS -#ifdef UFS -use stochastic_physics, only : run_stochastic_physics_ocn -#endif implicit none ; private @@ -218,8 +215,6 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics - logical,public :: do_epbl = .false. !< If true pertrub u_start in ePBL calculation - logical,public :: do_sppt = .false. !< If true perturb all physics tendenceies in MOM_diabatic_driver real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil @@ -270,21 +265,21 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, OBC, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, OBC, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + type(stochastic_pattern), intent(in) :: stochastics !< random patterns + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -305,36 +300,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts - real, dimension(SZI_(G),SZJ_(G),2) :: t_rp -#ifdef UFS real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT -#endif if (G%ke == 1) return -#ifdef UFS ! save copy of the date for SPPT - if (CS%do_sppt) then - h_in=h - t_in=tv%T - s_in=tv%S - endif - call run_stochastic_physics_ocn(t_rp,sppt_wts) - if (CS%id_t_rp1 > 0) then - call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) - endif - if (CS%id_t_rp2 > 0) then - call post_data(CS%id_t_rp2, t_rp(:,:,2), CS%diag) - endif - if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) + if (stochastics%do_sppt) then + h_in=h + t_in=tv%T + s_in=tv%S + + if (CS%id_sppt_wts > 0) then + call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) + endif endif -#endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -420,10 +403,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & @@ -490,14 +473,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) -#ifdef UFS - if (CS%do_sppt) then + if (stochastics%do_sppt) then do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*stochastics%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stochastics%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stochastics%sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) @@ -514,7 +496,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo endif -#endif end subroutine diabatic @@ -523,7 +504,7 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -533,10 +514,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] - type(forcing), intent(inout) :: fluxes !< points to forcing fields + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + type(stochastic_pattern), intent(in) :: stochastics !< points to forcing fields !! unused fields have NULL ptrs - real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived @@ -846,7 +827,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -1109,7 +1090,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1122,7 +1103,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived @@ -1383,7 +1364,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -3151,12 +3132,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & - 'random pattern1 for stochastics', 'None') - CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & - 'random pattern2 for stochastics', 'None') CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & - 'random pattern for sppt', 'None') + 'random pattern for sppt', 'None') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1cf089d5ed..a0b9ee0b51 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -14,7 +14,7 @@ module MOM_energetic_PBL use MOM_grid, only : ocean_grid_type use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : thermo_var_ptrs, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -165,7 +165,6 @@ module MOM_energetic_PBL !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in !! upward or downward passes. - logical :: do_epbl type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the !! timing of diagnostic output. @@ -198,6 +197,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 + integer :: id_t_rp1=-1,id_t_rp2=-1 !>@} end type energetic_PBL_CS @@ -245,7 +245,7 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & dT_expected, dS_expected, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -276,15 +276,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. + type(stochastic_pattern), intent(in) :: stochastics !< A structure containing array to any unsued fields + !! are not allocated real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces !! [Z2 s-1 ~> m2 s-1]. type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous !! call to mixedlayer_init. - real, dimension(SZI_(G),SZJ_(G),2), & - intent(in) :: t_rp !< random pattern to perturb wind - logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -429,9 +428,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, stochastics, & + B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & + GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -470,26 +469,30 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ enddo ! j-loop - if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) - if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) - if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) - if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) - if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) - if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) - if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) - if (CS%id_TKE_mech_decay > 0) & - call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) - if (CS%id_TKE_conv_decay > 0) & - call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) - if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) - if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) - if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) - if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - if (stoch_CS%pert_epbl) then - if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) - if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) + if (write_diags) then + if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) + if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) + if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) + if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) + if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) + ! only write random patterns if running with stochastic physics, otherwise the + ! array is unallocated and will give an error + if (stochastics%pert_epbl) then + if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) + if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + endif endif end subroutine energetic_PBL @@ -497,9 +500,9 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & +subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - t_rp1,t_rp2, stoch_epbl, dt_diag, Waves, G, i, j) + dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -518,6 +521,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. + type(stochastic_pattern), intent(in) :: stochastics !< stochastic patterns and logic controls real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. @@ -536,9 +540,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - real, intent(in) :: t_rp1 !< random value to perturb TKE production - real, intent(in) :: t_rp2 !< random value to perturb TKE dissipation - logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less !! than dt if there are two calls to mixedlayer [T ~> s]. type(wave_parameters_CS), & @@ -836,7 +837,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (stoch_epbl) mech_TKE=mech_TKE*t_rp1 + if (stochastics%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -919,8 +920,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (stoch_epbl) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stochastics%pert_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh endif @@ -2326,6 +2327,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') + CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + 'random pattern1 for stochastics', 'None') + CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + 'random pattern2 for stochastics', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From 9e7029ca85aa7bd5f34decc170be7d5e824ad40f Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 29 Jan 2021 20:49:07 +0000 Subject: [PATCH 012/155] clean up MOM_domains --- src/framework/MOM_domains.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index acbc1ccaea..ce4c1a9d6e 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,6 +3,8 @@ 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, Get_PElist 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 From 0bf4ff0a109c6e98507d6364d02b0179f229b49b Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 2 Feb 2021 00:05:24 +0000 Subject: [PATCH 013/155] make stochastics optional --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 17 ++- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 15 ++- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 80 ++++++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 13 +-- src/core/MOM.F90 | 25 ++-- src/core/MOM_variables.F90 | 2 - .../vertical/MOM_diabatic_driver.F90 | 110 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 56 ++++++--- 8 files changed, 181 insertions(+), 137 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 6292c32469..e0c512250b 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -50,7 +50,7 @@ module ocean_model_mod use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -186,7 +186,6 @@ module ocean_model_mod !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -562,7 +561,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. @@ -577,12 +576,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -604,16 +603,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -630,7 +629,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. Time1 = Time1 - real_to_time(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 4a4f6eee05..3bd0e1e28d 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -47,7 +47,7 @@ module MOM_ocean_model_mct use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -187,7 +187,6 @@ module MOM_ocean_model_mct !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -587,12 +586,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -616,16 +615,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -642,7 +641,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 290e6b30df..3ac6ef542d 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -177,10 +177,8 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: do_sppt !< If true, stochastically perturb the diabatic and - !! write restarts - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and - !! genration termsand write restarts + logical :: do_sppt !< If true, allocate array for SPPT + logical :: pert_epbl !< If true, allocate arrays for energetic PBL perturbations real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -435,20 +433,38 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - me=PE_here() - master=root_PE() - - call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& - OS%stochastics%pert_epbl,OS%stochastics%do_sppt,master,mom_comm,iret) - print*,'after init_stochastic_physics_ocn',OS%stochastics%pert_epbl,OS%stochastics%do_sppt +! get number of processors and PE list for stocasthci physics initialization + call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + if (OS%do_sppt .OR. OS%pert_epbl) then + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + me=PE_here() + master=root_PE() + + call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& + OS%pert_epbl,OS%do_sppt,master,mom_comm,iret) + if (iret/=0) then + write(6,*) 'call to init_stochastic_physics_ocn failed' + call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & + "not activated in stochastic_physics namelist ") + return + endif - if (OS%stochastics%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - if (OS%stochastics%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%pert_epbl) then + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + endif endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -622,8 +638,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time ! update stochastic physics patterns before running next time-step - print*,'before call to stoch',OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl - if (OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl ) then + if (OS%do_sppt .OR. OS%pert_epbl ) then call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) endif @@ -631,13 +646,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & - reset_therm=Ocn_fluxes_used) + reset_therm=Ocn_fluxes_used, stochastics=OS%stochastics) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves, & + stochastics=OS%stochastics) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -660,18 +676,21 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & + stochastics=OS%stochastics) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & + stochastics=OS%stochastics) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & + stochastics=OS%stochastics) step_thermo = .false. if (thermo_does_span_coupling) then @@ -686,9 +705,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & + stochastics=OS%stochastics) endif endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index ee5e92e0f4..afb1901e0a 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -62,7 +62,7 @@ program MOM_main 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, stochastic_pattern + 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 : Update_Surface_Waves @@ -91,7 +91,6 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes - type(stochastic_pattern) :: stochastics !< A structure containing pointers to ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state @@ -489,7 +488,7 @@ program MOM_main if (offline_tracer_mode) then call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, stochastics, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -502,16 +501,16 @@ program MOM_main if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) @@ -520,7 +519,7 @@ program MOM_main ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & Time2 = Time2 - real_to_time(dtdia - dt_dyn) - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) n_last_thermo = n diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 50e58b8a63..374d1be208 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -451,14 +451,13 @@ module MOM !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. -subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, time_int_in, CS, & +subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & - end_cycle, cycle_length, reset_therm) + end_cycle, cycle_length, reset_therm, stochastics) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state - type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM @@ -479,6 +478,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patternss for stochastics ! local variables type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing @@ -767,8 +767,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & - dtdia, end_time_thermo, .true., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + end_time_thermo, .true., Waves=Waves, & + stochastics=stochastics) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -868,8 +869,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti 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, stochastics, & - dtdia, Time_local, .false., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + Time_local, .false., Waves=Waves, & + stochastics=stochastics) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1301,8 +1303,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & - dtdia, Time_end_thermo, update_BBL, Waves) +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & + Time_end_thermo, update_BBL, Waves, stochastics) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1391,8 +1393,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, stochastics, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves, & + stochastics=stochastics) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 4020721075..4d5c83f3bd 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -277,8 +277,6 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. type, public :: stochastic_pattern - logical :: do_sppt = .false. - logical :: pert_epbl = .false. real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index df4dd4c453..f5bd2225a3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -142,12 +142,12 @@ module MOM_diabatic_driver integer :: NKBL !< The number of buffer layers (if bulk_mixed_layer) logical :: massless_match_targets !< If true (the default), keep the T & S !! consistent with the target values. - logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless layers at the - !! bottom into the interior as though a diffusivity of - !! Kd_min_tr (see below) were operating. - logical :: mix_boundary_tracer_ALE !< If true, in ALE mode mix the passive tracers in massless - !! layers at the bottom into the interior as though a - !! diffusivity of Kd_min_tr (see below) were operating. + logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless + !! layers at the bottom into the interior as though + !! a diffusivity of Kd_min_tr (see below) were + !! operating. + logical :: do_sppt !< If true, stochastically perturb the diabatic + !! tendencies with a number between 0 and 2 real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at @@ -183,7 +183,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1 = -1, id_t_rp2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -265,8 +265,8 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES) +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, OBC, WAVES, stochastics) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -277,19 +277,18 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -300,16 +299,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickenss before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT + real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT if (G%ke == 1) return ! save copy of the date for SPPT - if (stochastics%do_sppt) then + if (CS%do_sppt) then h_in=h t_in=tv%T s_in=tv%S @@ -403,11 +402,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves,stochastics=stochastics) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves, stochastics=stochastics) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -473,7 +472,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stochastics%do_sppt) then + if (CS%do_sppt) then do k=1,nz do j=js,je do i=is,ie @@ -504,8 +503,8 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES) +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES, stochastics) 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 @@ -516,18 +515,17 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields - type(stochastic_pattern), intent(in) :: stochastics !< points to forcing fields - !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and + !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -827,8 +825,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + waves=waves, stochastics=stochastics) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -1090,8 +1089,8 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves, stochastics) 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 @@ -1103,17 +1102,17 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, d real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and + !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1364,8 +1363,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + waves=waves, stochastics=stochastics) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -3088,9 +3088,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "mass loss is passed down through the column.", & units="nondim", default=0.8) - if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & - call MOM_error(FATAL, "diabatic_driver_init: "//& - "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") + call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) ! Register all available diagnostics for this module. thickness_units = get_thickness_units(GV) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index a0b9ee0b51..4ef7239791 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -58,6 +58,7 @@ module MOM_energetic_PBL !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. real :: MixLenExponent !< Exponent in the mixing length shape-function. @@ -245,9 +246,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves ) + dT_expected, dS_expected, Waves, stochastics ) 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 @@ -276,8 +277,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. - type(stochastic_pattern), intent(in) :: stochastics !< A structure containing array to any unsued fields - !! are not allocated real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces @@ -286,8 +285,26 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, !! call to mixedlayer_init. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. - type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less + !! than dt if there are two calls to mixedlayer [T ~> s]. + logical, optional, intent(in) :: last_call !< If true, this is the last call to + !! mixedlayer in the current time step, so + !! diagnostics will be written. The default + !! is .true. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dT_expected !< The values of temperature change that + !! should be expected when the returned + !! diffusivities are applied [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dS_expected !< The values of salinity change that + !! should be expected when the returned + !! diffusivities are applied [ppt]. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Wave CS + type(stochastic_pattern), optional, & + intent(in) :: stochastics !< A structure containing array to stochastic + !! patterns. Any unsued fields + !! are not allocated ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -428,9 +445,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, stochastics, & + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, & B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & - GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + stochastics=stochastics,i=i, j=j) ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -489,7 +507,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error - if (stochastics%pert_epbl) then + if (CS%pert_epbl) then if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) endif @@ -500,9 +518,9 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics, B_flux, absf, & +subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, i, j) + dt_diag, Waves, G, stochastics, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -521,7 +539,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. - type(stochastic_pattern), intent(in) :: stochastics !< stochastic patterns and logic controls real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. @@ -546,6 +563,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics optional, pointer :: Waves !< Wave CS for Langmuir turbulence type(ocean_grid_type), & optional, intent(inout) :: G !< The ocean's grid structure. + type(stochastic_pattern), & + optional, intent(in) :: stochastics !< stochastic patterns and logic controls integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) @@ -837,7 +856,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (stochastics%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -920,7 +939,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (stochastics%pert_epbl) then ! perturb the TKE destruction + if (CS%pert_epbl) then ! perturb the TKE destruction mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh @@ -2153,6 +2172,11 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "This is only used if USE_MLD_ITERATION is True.", & units="nondim", default=2.0) + call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) !/ Turbulent velocity scale in mixing coefficient call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & "Selects the method for translating TKE into turbulent velocities. "//& @@ -2328,9 +2352,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & - 'random pattern1 for stochastics', 'None') + 'random pattern for KE generation', 'None') CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & - 'random pattern2 for stochastics', 'None') + 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From e80d5f57ee97f290dbcf98b4d4ee894c389b2523 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 2 Feb 2021 00:13:24 +0000 Subject: [PATCH 014/155] correct coupled_driver/ocean_model_MOM.F90 and other cleanup --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 2 +- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index e0c512250b..97fb869ad4 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -561,7 +561,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. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f5bd2225a3..6ea57f56eb 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -299,7 +299,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickenss before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickness before thermodynamics real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT @@ -403,7 +403,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves,stochastics=stochastics) + G, GV, US, CS, Waves, stochastics=stochastics) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves, stochastics=stochastics) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 4ef7239791..7ad3aea276 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -445,9 +445,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, & - B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & - GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & stochastics=stochastics,i=i, j=j) ! Copy the diffusivities to a 2-d array. From 08dc1a44b8c5d442ea19df9f402604f4f34c4ff6 Mon Sep 17 00:00:00 2001 From: Philip Pegion Date: Tue, 2 Feb 2021 09:45:46 -0600 Subject: [PATCH 015/155] clean up of code for MOM6 coding standards --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 8 +++--- src/core/MOM.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 27 ++++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 10 +++---- 4 files changed, 24 insertions(+), 23 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 3ac6ef542d..c20b0a08ef 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -460,10 +460,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i return endif - if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) if (OS%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) endif endif call close_param_file(param_file) @@ -639,7 +639,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! update stochastic physics patterns before running next time-step if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) + call run_stochastic_physics_ocn(OS%stochastics%sppt_wts, OS%stochastics%t_rp1, OS%stochastics%t_rp2) endif if (OS%offline_tracer_mode) then diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 374d1be208..3edc7b6b9c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -132,7 +132,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state,stochastic_pattern +use MOM_variables, only : rotate_surface_state, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6ea57f56eb..9faf8616b8 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -309,9 +309,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! save copy of the date for SPPT if (CS%do_sppt) then - h_in=h - t_in=tv%T - s_in=tv%S + h_in(:,:,:)=h(:,:,:) + t_in(:,:,:)=tv%T(:,:,:) + s_in(:,:,:)=tv%S(:,:,:) if (CS%id_sppt_wts > 0) then call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) @@ -473,23 +473,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) if (CS%do_sppt) then + ! perturb diabatic tendecies do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stochastics%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stochastics%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stochastics%sppt_wts(i,j) - h_pert=h_tend+h_in(i,j,k) - t_pert=t_tend+t_in(i,j,k) - s_pert=s_tend+s_in(i,j,k) + h_tend = (h(i,j,k) - h_in(i,j,k)) * stochastics%sppt_wts(i,j) + t_tend = (tv%T(i,j,k) - t_in(i,j,k)) * stochastics%sppt_wts(i,j) + s_tend = (tv%S(i,j,k) - s_in(i,j,k)) * stochastics%sppt_wts(i,j) + h_pert = h_tend + h_in(i,j,k) + t_pert = t_tend + t_in(i,j,k) + s_pert = s_tend + s_in(i,j,k) if (h_pert > GV%Angstrom_H) then - h(i,j,k)=h_pert + h(i,j,k) = h_pert else - h(i,j,k)=GV%Angstrom_H + h(i,j,k) = GV%Angstrom_H endif - tv%T(i,j,k)=t_pert + tv%T(i,j,k) = t_pert if (s_pert > 0.0) then - tv%S(i,j,k)=s_pert + tv%S(i,j,k) = s_pert endif enddo enddo diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7ad3aea276..1655cdab4c 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -198,7 +198,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_t_rp1=-1,id_t_rp2=-1 + integer :: id_t_rp1=-1, id_t_rp2=-1 !>@} end type energetic_PBL_CS @@ -508,8 +508,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error if (CS%pert_epbl) then - if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) - if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) + if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) endif endif end subroutine energetic_PBL @@ -856,7 +856,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE = mech_TKE * stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -939,7 +939,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE destruction + if (CS%pert_epbl) then ! perturb the TKE dissipation mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh From c7531a75f4a7cb1e552666089fe9daf0a2a8235e Mon Sep 17 00:00:00 2001 From: pjpegion Date: Thu, 4 Feb 2021 16:59:22 +0000 Subject: [PATCH 016/155] remove stochastics container --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 37 ++++++------- src/core/MOM.F90 | 15 ++---- src/core/MOM_forcing_type.F90 | 4 ++ src/core/MOM_variables.F90 | 5 -- src/framework/MOM_domains.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 52 +++++++++---------- .../vertical/MOM_energetic_PBL.F90 | 45 ++++++++-------- 7 files changed, 73 insertions(+), 87 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index c20b0a08ef..ea64808f26 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -43,7 +43,7 @@ module MOM_ocean_model_nuopc use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -51,7 +51,7 @@ module MOM_ocean_model_nuopc 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 : domain2d, mpp_get_layout, mpp_get_global_domain,mpp_get_pelist use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use fms_mod, only : stdout use mpp_mod, only : mpp_chksum @@ -62,7 +62,7 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs +use MOM_domains, only : root_PE,PE_here,num_PEs use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -192,7 +192,6 @@ module MOM_ocean_model_nuopc !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -256,7 +255,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot!< If true, allocate melt_potential array ! stochastic physics - integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean integer :: mom_comm ! list of pes for this instance of the ocean integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics @@ -446,8 +444,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i default=.false.) if (OS%do_sppt .OR. OS%pert_epbl) then num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) + call mpp_get_pelist(Ocean_sfc%domain, mom_comm) me=PE_here() master=root_PE() @@ -460,10 +457,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i return endif - if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%fluxes%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) if (OS%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + allocate(OS%fluxes%epbl1_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%fluxes%epbl2_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) endif endif call close_param_file(param_file) @@ -639,7 +636,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! update stochastic physics patterns before running next time-step if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%stochastics%sppt_wts, OS%stochastics%t_rp1, OS%stochastics%t_rp2) + call run_stochastic_physics_ocn(OS%fluxes%sppt_wts,OS%fluxes%epbl1_wts,OS%fluxes%epbl2_wts) endif if (OS%offline_tracer_mode) then @@ -648,12 +645,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! The call sequence is being orchestrated from outside of update_ocean_model. call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & - reset_therm=Ocn_fluxes_used, stochastics=OS%stochastics) + reset_therm=Ocn_fluxes_used) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves, & - stochastics=OS%stochastics) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -678,19 +674,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & dtdia = dt_dyn*min(nts,n_max-(n-1)) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -707,8 +700,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + endif endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3edc7b6b9c..440ddce0be 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -453,7 +453,7 @@ module MOM !! occur inside of diabatic. subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & - end_cycle, cycle_length, reset_therm, stochastics) + end_cycle, cycle_length, reset_therm) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields @@ -478,7 +478,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patternss for stochastics ! local variables type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing @@ -768,8 +767,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - end_time_thermo, .true., Waves=Waves, & - stochastics=stochastics) + end_time_thermo, .true., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -870,8 +868,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - Time_local, .false., Waves=Waves, & - stochastics=stochastics) + Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1304,7 +1301,7 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & - Time_end_thermo, update_BBL, Waves, stochastics) + Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1317,7 +1314,6 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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 - type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. @@ -1394,8 +1390,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves, & - stochastics=stochastics) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3248c09fa4..ab782df7b8 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,6 +170,10 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + ! stochastic patterns + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 4d5c83f3bd..a9bf6c3dcf 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -276,11 +276,6 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. -type, public :: stochastic_pattern - real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation - real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation -end type stochastic_pattern type, public :: BT_cont_type real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport !! drawing from locations far to the east [H L ~> m2 or kg m-1]. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index ce4c1a9d6e..1bb38bc0aa 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -17,7 +17,7 @@ module MOM_domains 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 :: pass_var, pass_vector, PE_here, root_PE, num_PEs, Get_PElist +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 :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9faf8616b8..312462b45b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -65,7 +65,7 @@ module MOM_diabatic_driver use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs -use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d, stochastic_pattern +use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS @@ -183,7 +183,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1 = -1, id_t_rp2 = -1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -266,7 +266,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES, stochastics) + G, GV, US, CS, OBC, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -288,7 +288,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(diabatic_CS), pointer :: CS !< module control structure type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -299,9 +298,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickness before thermodynamics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics + real, allocatable(:,:,:) :: h_in ! thickness before thermodynamics + real, allocatable(:,:,:) :: t_in ! temperature before thermodynamics + real, allocatable(:,:,:) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT @@ -309,12 +308,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! save copy of the date for SPPT if (CS%do_sppt) then - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) + allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + h_in(:,:) = h(:,:) + t_in(:,:) = tv%T(:,:) + s_in(:,:) = tv%S(:,:) if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) + call post_data(CS%id_sppt_wts, fluxes%sppt_wts, CS%diag) endif endif @@ -403,10 +405,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics=stochastics) + G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics=stochastics) + G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -477,12 +479,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k) - h_in(i,j,k)) * stochastics%sppt_wts(i,j) - t_tend = (tv%T(i,j,k) - t_in(i,j,k)) * stochastics%sppt_wts(i,j) - s_tend = (tv%S(i,j,k) - s_in(i,j,k)) * stochastics%sppt_wts(i,j) - h_pert = h_tend + h_in(i,j,k) - t_pert = t_tend + t_in(i,j,k) - s_pert = s_tend + s_in(i,j,k) + h_tend = (h(i,j,k)-h_in(i,j,k))*fluxes%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*fluxes%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*fluxes%sppt_wts(i,j) + h_pert=h_tend+h_in(i,j,k) + t_pert=t_tend+t_in(i,j,k) + s_pert=s_tend+s_in(i,j,k) if (h_pert > GV%Angstrom_H) then h(i,j,k) = h_pert else @@ -505,7 +507,7 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES, stochastics) + G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -525,8 +527,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and - !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -828,7 +828,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves, stochastics=stochastics) + waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -1091,7 +1091,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics) + G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1112,8 +1112,6 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and - !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1366,7 +1364,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves, stochastics=stochastics) + waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1655cdab4c..8a708e4861 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -14,7 +14,7 @@ module MOM_energetic_PBL use MOM_grid, only : ocean_grid_type use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs, stochastic_pattern +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -198,7 +198,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_t_rp1=-1, id_t_rp2=-1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 !>@} end type energetic_PBL_CS @@ -248,7 +248,7 @@ module MOM_energetic_PBL !! is no stability limit on the time step. subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves, stochastics ) + dT_expected, dS_expected, Waves) 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 @@ -301,10 +301,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS !! diffusivities are applied [ppt]. type(wave_parameters_CS), & optional, pointer :: Waves !< Wave CS - type(stochastic_pattern), optional, & - intent(in) :: stochastics !< A structure containing array to stochastic - !! patterns. Any unsued fields - !! are not allocated ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -444,11 +440,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - stochastics=stochastics,i=i, j=j) + if (CS%pert_epbl) then ! stochastics are active + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + epbl1_wt=epbl1_wts(i,j),epbl2_wt=epbl2_wts(i,j),i=i, j=j) + else + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + endif ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -508,8 +509,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error if (CS%pert_epbl) then - if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) - if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + if (CS%id_epbl1_wts > 0) call post_data(CS%id_epbl1_wts, stochastics%epbl1_wts, CS%diag) + if (CS%id_epbl2_wts > 0) call post_data(CS%id_epbl2_wts, stochastics%epbl2_wts, CS%diag) endif endif end subroutine energetic_PBL @@ -520,7 +521,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, stochastics, i, j) + dt_diag, Waves, G, epbl1_wt, epbl2_wt, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -563,8 +564,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs optional, pointer :: Waves !< Wave CS for Langmuir turbulence type(ocean_grid_type), & optional, intent(inout) :: G !< The ocean's grid structure. - type(stochastic_pattern), & - optional, intent(in) :: stochastics !< stochastic patterns and logic controls + real, optional, intent(in) :: epbl1_wt ! random number to perturb KE generation + real, optional, intent(in) :: epbl2_wt ! random number to perturb KE dissipation integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) @@ -856,7 +857,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE = mech_TKE * stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE=mech_TKE*epbl1_wt if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -939,8 +940,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE dissipation - mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) + if (CS%pert_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) else mech_TKE = mech_TKE * exp_kh endif @@ -2351,9 +2352,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') - CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', diag%axesT1, Time, & 'random pattern for KE generation', 'None') - CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', diag%axesT1, Time, & 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & From 4c931094f26b92ed107a43526765f74d48c3d404 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:18:31 +0000 Subject: [PATCH 017/155] revert MOM_domains.F90 --- src/framework/MOM_domains.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 1bb38bc0aa..2b30a4d629 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,9 +3,8 @@ 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, Get_PElist +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 From ea36db2385ff9d15d070d06812255feecf8d5742 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:50:56 +0000 Subject: [PATCH 018/155] clean up of mom_ocean_model_nuopc.F90 --- config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index ea64808f26..9e43638751 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -51,7 +51,7 @@ module MOM_ocean_model_nuopc 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,mpp_get_pelist +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 mpp_mod, only : mpp_chksum @@ -444,7 +444,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i default=.false.) if (OS%do_sppt .OR. OS%pert_epbl) then num_procs=num_PEs() - call mpp_get_pelist(Ocean_sfc%domain, mom_comm) + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) me=PE_here() master=root_PE() @@ -701,7 +702,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) - endif endif From e2431bc81bdeb2af2929782c220e7019ff167892 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:54:05 +0000 Subject: [PATCH 019/155] remove PE_here from mom_ocean_model_nuopc.F90 --- config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 9e43638751..1ef5b07c06 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -62,7 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,PE_here,num_PEs +use MOM_domains, only : root_PE,num_PEs +use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -446,7 +447,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - me=PE_here() master=root_PE() call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& From a67bc78a291e1184528896564b1bc103999d2b01 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 26 Feb 2021 17:43:50 +0000 Subject: [PATCH 020/155] remove debug statements --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 8a708e4861..7cf8d48ae0 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -945,6 +945,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = mech_TKE * exp_kh endif + !if ( i .eq. 10 .and. j .eq. 10 .and. k .eq. nz) print*,'mech TKE', mech_TKE ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 493717a353382cfa1c6136165323921407421ee6 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 15:09:50 +0000 Subject: [PATCH 021/155] stochastic physics re-write --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 38 +---- src/core/MOM.F90 | 25 +-- src/core/MOM_forcing_type.F90 | 4 - .../stochastic/MOM_stochastics.F90 | 50 +++--- .../stochastic/MOM_stochastics_stub.F90 | 64 ++++++++ .../vertical/MOM_diabatic_driver.F90 | 155 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 34 ++-- 7 files changed, 204 insertions(+), 166 deletions(-) create mode 100644 src/parameterizations/stochastic/MOM_stochastics_stub.F90 diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1ef5b07c06..9ffe4cd794 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -64,7 +64,6 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : forcing_save_restart use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist -use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -178,8 +177,8 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: do_sppt !< If true, allocate array for SPPT - logical :: pert_epbl !< If true, allocate arrays for energetic PBL perturbations + logical,public :: do_sppt !< If true, write stochastic physics restarts + logical,public :: pert_epbl !< If true, write stochastic physics restarts real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -255,12 +254,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot!< If true, allocate melt_potential array -! stochastic physics - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs ! number of processors to pass to stochastic physics - integer :: iret ! return code from stochastic physics - integer :: me ! my pe - integer :: master ! root pe ! This include declares and sets the variable "version". #include "version_variable.h" @@ -432,7 +425,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif -! get number of processors and PE list for stocasthci physics initialization + ! check to see if stochastic physics is active call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& "tendemcies of T,S, amd h. Amplitude and correlations are "//& @@ -443,27 +436,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "production and dissipation terms. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) - if (OS%do_sppt .OR. OS%pert_epbl) then - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - master=root_PE() - - call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& - OS%pert_epbl,OS%do_sppt,master,mom_comm,iret) - if (iret/=0) then - write(6,*) 'call to init_stochastic_physics_ocn failed' - call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & - "not activated in stochastic_physics namelist ") - return - endif - if (OS%do_sppt) allocate(OS%fluxes%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - if (OS%pert_epbl) then - allocate(OS%fluxes%epbl1_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%fluxes%epbl2_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - endif - endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -635,11 +608,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time -! update stochastic physics patterns before running next time-step - if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%fluxes%sppt_wts,OS%fluxes%epbl1_wts,OS%fluxes%epbl2_wts) - endif - if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 440ddce0be..71009d225d 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -402,16 +402,6 @@ module MOM type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling !! ensemble model state vectors and data assimilation !! increments and priors - type(porous_barrier_ptrs) :: pbv !< porous barrier fractional cell metrics - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) & - :: por_face_areaU !< fractional open area of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) & - :: por_face_areaV !< fractional open area of V-faces [nondim] - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) & - :: por_layer_widthU !< fractional open width of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) & - :: por_layer_widthV !< fractional open width of V-faces [nondim] - type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure end type MOM_control_struct @@ -672,7 +662,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call disable_averaging(CS%diag) endif endif - ! advance the random pattern if stochastic physics is active + if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then @@ -824,6 +814,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & Time_local, Waves=Waves) @@ -1390,7 +1381,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS,OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -2498,6 +2489,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & else call set_first_direction(G, modulo(first_direction, 2)) endif + call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + call destroy_dyn_horgrid(dG_in) + + if (.not. CS%rotate_index) & + G => G_in + ! initialize stochastic physics + !call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) + ! Set a few remaining fields that are specific to the ocean grid type. + call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ab782df7b8..3248c09fa4 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,10 +170,6 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] - ! stochastic patterns - real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation - real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 21a22a222e..5bcf158f7e 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -4,10 +4,13 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. ! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, update, and writing restart of stochastic physics. This +! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. + use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type @@ -26,13 +29,11 @@ module MOM_stochastics public stochastics_init, update_stochastics -!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT - integer :: id_epbl1_wts=-1 !< Diagnostic id for epbl generation perturbation - integer :: id_epbl2_wts=-1 !< Diagnostic id for epbl dissipation perturbation + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 @@ -42,14 +43,22 @@ module MOM_stochastics type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type stochastic_CS +!> This type is used for communication with other components via the FMS coupler. +!! The element names and types can be changed only with great deliberation, hence +!! the persistnce of things like the cutsy element name "avg_kount". contains -!! This subroutine initializes the stochastics physics control structure. +!> ocean_model_init initializes the ocean model, including registering fields +!! for restarts and reading restart files if appropriate. +!! +!! This subroutine initializes both the ocean state and the ocean surface type. +!! Because of the way that indicies and domains are handled, Ocean_sfc must have +!! been used in a previous call to cean_type. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid !< horizontal grid information - type(verticalGrid_type), intent(in) :: GV !< vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS !< stochastic control structure + type(ocean_grid_type), intent(in) :: grid ! horizontal grid information + type(verticalGrid_type), intent(in) :: GV ! vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(time_type), target :: Time !< model time @@ -59,7 +68,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics integer :: me ! my pe - integer :: pe_zero ! root pe + integer :: master ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo @@ -95,13 +104,15 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - pe_zero=root_PE() - nx = grid%ied - grid%isd + 1 - ny = grid%jed - grid%jsd + 1 + master=root_PE() + nx=grid%ied-grid%isd+1 + ny=grid%jed-grid%jsd+1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) + CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then - call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") + write(6,*) 'call to init_stochastic_physics_ocn failed' + call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & + "not activated in stochastic_physics namelist ") return endif @@ -122,7 +133,6 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) write(*,'(/12x,a/)') '=== COMPLETED MOM STOCHASTIC INITIALIZATION =====' call callTree_leave("ocean_model_init(") - return end subroutine stochastics_init !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the @@ -135,9 +145,9 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + print*,'in update_stoch',minval(CS%sppt_wts),maxval(CS%sppt_wts),minval(CS%epbl1_wts),maxval(CS%epbl1_wts) - return end subroutine update_stochastics end module MOM_stochastics diff --git a/src/parameterizations/stochastic/MOM_stochastics_stub.F90 b/src/parameterizations/stochastic/MOM_stochastics_stub.F90 new file mode 100644 index 0000000000..f03f5283d3 --- /dev/null +++ b/src/parameterizations/stochastic/MOM_stochastics_stub.F90 @@ -0,0 +1,64 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. +module MOM_stochastics + +! This file is part of MOM6. See LICENSE.md for the license. + +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, termination and update of ocean model state. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. + +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +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 MOM_domains, only : root_PE,num_PEs +use MOM_coms, only : Get_PElist + +#include + +implicit none ; private + +public stochastics_init, update_stochastics + +type, public:: stochastic_CS + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + ! stochastic patterns + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + !! tendencies with a number between 0 and 2 + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) +end type stochastic_CS + +contains + +subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) + real, intent(in) :: dt !< time step [T ~> s] + type(ocean_grid_type), intent(in) :: grid ! horizontal grid information + type(verticalGrid_type), intent(in) :: GV ! vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(time_type), target :: Time !< model time + return +end subroutine stochastics_init + +subroutine update_stochastics(CS) + type(stochastic_CS), intent(inout) :: CS !< diabatic control structure + return +end subroutine update_stochastics + +end module MOM_stochastics + diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 312462b45b..ffbbd2c7d1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,6 +69,7 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS +use MOM_stochastics, only : stochastic_CS implicit none ; private @@ -142,12 +143,12 @@ module MOM_diabatic_driver integer :: NKBL !< The number of buffer layers (if bulk_mixed_layer) logical :: massless_match_targets !< If true (the default), keep the T & S !! consistent with the target values. - logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless - !! layers at the bottom into the interior as though - !! a diffusivity of Kd_min_tr (see below) were - !! operating. - logical :: do_sppt !< If true, stochastically perturb the diabatic - !! tendencies with a number between 0 and 2 + logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless layers at the + !! bottom into the interior as though a diffusivity of + !! Kd_min_tr (see below) were operating. + logical :: mix_boundary_tracer_ALE !< If true, in ALE mode mix the passive tracers in massless + !! layers at the bottom into the interior as though a + !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at @@ -175,15 +176,20 @@ module MOM_diabatic_driver real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) - integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic - integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 - integer :: id_ea_t = -1, id_eb_t = -1 - integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 - integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 - integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1 + integer :: id_cg1 = -1 ! diag handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds + integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 + integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 + ! These are handles to diagnostics related to the mixed layer properties. + integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 + + ! These are handles to diatgnostics that are only available in non-ALE layered mode. + integer :: id_wd = -1 + integer :: id_dudt_dia = -1, id_dvdt_dia = -1 + integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -266,13 +272,13 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, OBC, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + 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] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -281,13 +287,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diabatic_CS), pointer :: CS !< module control structure - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -307,16 +314,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (G%ke == 1) return ! save copy of the date for SPPT - if (CS%do_sppt) then + if (stoch_CS%do_sppt) then allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:) = h(:,:) - t_in(:,:) = tv%T(:,:) - s_in(:,:) = tv%S(:,:) + h_in(:,:,:)=h(:,:,:) + t_in(:,:,:)=tv%T(:,:,:) + s_in(:,:,:)=tv%S(:,:,:) - if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, fluxes%sppt_wts, CS%diag) + if (stoch_CS%id_sppt_wts > 0) then + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) endif endif @@ -405,10 +412,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + G, GV, US, CS, stoch_CS, Waves) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + G, GV, US, CS, stoch_CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -474,14 +481,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (CS%do_sppt) then + if (stoch_CS%do_sppt) then ! perturb diabatic tendecies do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*fluxes%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*fluxes%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*fluxes%sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) @@ -507,14 +514,14 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -522,11 +529,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -827,7 +835,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & waves=waves) if (associated(Hml)) then @@ -1091,14 +1099,14 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -1107,11 +1115,12 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1363,7 +1372,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & waves=waves) if (associated(Hml)) then @@ -3087,11 +3096,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "mass loss is passed down through the column.", & units="nondim", default=0.8) - call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & - "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) + if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & + call MOM_error(FATAL, "diabatic_driver_init: "//& + "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") ! Register all available diagnostics for this module. thickness_units = get_thickness_units(GV) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7cf8d48ae0..36e92c2850 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -58,7 +58,6 @@ module MOM_energetic_PBL !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. real :: MixLenExponent !< Exponent in the mixing length shape-function. @@ -198,7 +197,6 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 !>@} end type energetic_PBL_CS @@ -246,9 +244,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, & + last_call, dT_expected, dS_expected, Waves) 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 @@ -301,6 +299,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS !! diffusivities are applied [ppt]. type(wave_parameters_CS), & optional, pointer :: Waves !< Wave CS + type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -440,11 +440,12 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - if (CS%pert_epbl) then ! stochastics are active + if (stoch_CS%pert_epbl) then ! stochastics are active call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - epbl1_wt=epbl1_wts(i,j),epbl2_wt=epbl2_wts(i,j),i=i, j=j) + epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j), & + i=i, j=j) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & @@ -508,9 +509,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error - if (CS%pert_epbl) then - if (CS%id_epbl1_wts > 0) call post_data(CS%id_epbl1_wts, stochastics%epbl1_wts, CS%diag) - if (CS%id_epbl2_wts > 0) call post_data(CS%id_epbl2_wts, stochastics%epbl2_wts, CS%diag) + if (stoch_CS%pert_epbl) then + if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) + if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif endif end subroutine energetic_PBL @@ -857,7 +858,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE=mech_TKE*epbl1_wt + if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -940,7 +941,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE destruction + if (present(epbl2_wt)) then ! perturb the TKE destruction mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) else mech_TKE = mech_TKE * exp_kh @@ -2174,11 +2175,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "This is only used if USE_MLD_ITERATION is True.", & units="nondim", default=2.0) - call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & - "If true, then stochastically perturb the kinetic energy "//& - "production and dissipation terms. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) !/ Turbulent velocity scale in mixing coefficient call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & "Selects the method for translating TKE into turbulent velocities. "//& @@ -2353,10 +2349,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') - CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', diag%axesT1, Time, & - 'random pattern for KE generation', 'None') - CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', diag%axesT1, Time, & - 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From cf1d29628395dab0f94676b9ed853f5166287e56 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 17:35:27 +0000 Subject: [PATCH 022/155] move stochastics to external directory --- .../external/OCEAN_stochastic_phyiscs}/MOM_stochastics.F90 | 0 .../external/OCEAN_stochastic_phyiscs}/MOM_stochastics_stub.F90 | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {src/parameterizations/stochastic => config_src/external/OCEAN_stochastic_phyiscs}/MOM_stochastics.F90 (100%) rename {src/parameterizations/stochastic => config_src/external/OCEAN_stochastic_phyiscs}/MOM_stochastics_stub.F90 (100%) diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 similarity index 100% rename from src/parameterizations/stochastic/MOM_stochastics.F90 rename to config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 diff --git a/src/parameterizations/stochastic/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 similarity index 100% rename from src/parameterizations/stochastic/MOM_stochastics_stub.F90 rename to config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 From e91c96609e93e9f34515baa4957272bb4ccafddc Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 18:14:44 +0000 Subject: [PATCH 023/155] doxygen cleanup --- .../external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 | 5 +++-- .../OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 | 7 +++++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 1 - 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 5bcf158f7e..03b33dc2b3 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -29,6 +29,7 @@ module MOM_stochastics public stochastics_init, update_stochastics +!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS logical :: do_sppt !< If true, stochastically perturb the diabatic logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms @@ -105,8 +106,8 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) master=root_PE() - nx=grid%ied-grid%isd+1 - ny=grid%jed-grid%jsd+1 + nx = grid%ied - grid%isd + 1 + ny = grid%jed - grid%jsd + 1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 index f03f5283d3..89a6d43c4f 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 @@ -28,11 +28,14 @@ module MOM_stochastics public stochastics_init, update_stochastics +!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms + !>@{ Diagnostic IDs integer :: id_sppt_wts = -1 integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + !>@} ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 36e92c2850..9ecba8a7b8 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -301,7 +301,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS optional, pointer :: Waves !< Wave CS type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous - ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes ! have already been applied. All calculations are done implicitly, and there From a5d90655d884fbbc3a3dda67368479935cb11341 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 21:41:16 +0000 Subject: [PATCH 024/155] add write_stoch_restart_ocn to MOM_stochastics --- config_src/drivers/nuopc_cap/mom_cap.F90 | 18 +++++++++++------- .../MOM_stochastics.F90 | 18 +++++++++++++++--- 2 files changed, 26 insertions(+), 10 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 3de56c0511..25de32d526 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,8 +97,8 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -use get_stochy_pattern_mod, only: write_stoch_restart_ocn +use MOM_stochastics, only : write_mom_restart_stoch !$use omp_lib , only : omp_set_num_threads implicit none; private @@ -1752,12 +1752,16 @@ subroutine ModelAdvance(gcomp, rc) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname) - ! write stochastic physics restart file if active - if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc" - else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" + if (ocean_state%do_sppt .OR. ocean_state%pert_epbl) then + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"ocn_stoch.res.nc" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" + endif + call ESMF_LogWrite("MOM_cap: Writing stoch restart : "//trim(restartname), & + ESMF_LOGMSG_INFO) + call write_mom_restart_stoch('RESTART/'//trim(restartname)) endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 03b33dc2b3..ab33a17c29 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -22,12 +22,13 @@ module MOM_stochastics use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn +use get_stochy_pattern_mod, only: write_stoch_restart_ocn #include implicit none ; private -public stochastics_init, update_stochastics +public stochastics_init, update_stochastics, write_mom_restart_stoch !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS @@ -146,10 +147,21 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) - print*,'in update_stoch',minval(CS%sppt_wts),maxval(CS%sppt_wts),minval(CS%epbl1_wts),maxval(CS%epbl1_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + return end subroutine update_stochastics +!< wrapper to write ocean stochastic restarts +subroutine write_mom_restart_stoch(filename) + character(len=*) :: filename + + call callTree_enter("write_mom_restart_stoch(), MOM_stochastics.F90") + + call write_stoch_restart_ocn(filename) + + return +end subroutine write_mom_restart_stoch + end module MOM_stochastics From 78b8d79193c61166f07b2a92e4a87005109201e6 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 27 Jul 2021 17:08:13 +0000 Subject: [PATCH 025/155] add logic to remove incrments from restart if outside IAU window --- src/ocean_data_assim/MOM_oda_incupd.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index ab3621296f..269b584006 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -554,6 +554,16 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) if (CS%ncount >= CS%nstep_incupd) then if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") return + if (CS%ncount == CS%nstep_incupd) then + call register_restart_field_as_obsolete("oda_incupd_ncount", "none", CS) + call register_restart_field_as_obsolete("T_inc", "none", CS) + call register_restart_field_as_obsolete("S_inc", "none", CS) + call register_restart_field_as_obsolete("h_obs", "none", CS) + if (CS%uv_inc) then + call register_restart_field_as_obsolete("u_inc", "none", CS) + call register_restart_field_as_obsolete("v_inc", "none", CS) + endif + endif endif !ncount>CS%nstep_incupd ! update counter From 15e4029400c3bbe21cb89e1accced65ea09c771a Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 28 Jul 2021 17:35:21 +0000 Subject: [PATCH 026/155] revert logic wrt increments --- src/ocean_data_assim/MOM_oda_incupd.F90 | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 269b584006..8b93582e4b 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -416,7 +416,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo endif enddo; enddo - + ! remap u to h_obs to get increment if (CS%uv_inc) then call pass_var(h, G%Domain) @@ -554,16 +554,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) if (CS%ncount >= CS%nstep_incupd) then if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") return - if (CS%ncount == CS%nstep_incupd) then - call register_restart_field_as_obsolete("oda_incupd_ncount", "none", CS) - call register_restart_field_as_obsolete("T_inc", "none", CS) - call register_restart_field_as_obsolete("S_inc", "none", CS) - call register_restart_field_as_obsolete("h_obs", "none", CS) - if (CS%uv_inc) then - call register_restart_field_as_obsolete("u_inc", "none", CS) - call register_restart_field_as_obsolete("v_inc", "none", CS) - endif - endif endif !ncount>CS%nstep_incupd ! update counter From 59e733f3e44611d7fefbd6f2fc74e8f70060c105 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 28 Jul 2021 19:40:29 +0000 Subject: [PATCH 027/155] add comments --- .../MOM_stochastics.F90 | 16 +++------------- .../MOM_stochastics_stub.F90 | 17 +++++++++-------- src/core/MOM.F90 | 4 +--- .../vertical/MOM_diabatic_driver.F90 | 2 +- 4 files changed, 14 insertions(+), 25 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index ab33a17c29..427b3c754b 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -4,13 +4,10 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. ! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, termination and update of ocean model state. This +! for initialization, update, and writing restart of stochastic physics. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! -! This code is a stop-gap wrapper of the MOM6 code to enable it to be called -! in the same way as MOM4. - use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type @@ -45,17 +42,9 @@ module MOM_stochastics type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type stochastic_CS -!> This type is used for communication with other components via the FMS coupler. -!! The element names and types can be changed only with great deliberation, hence -!! the persistnce of things like the cutsy element name "avg_kount". contains -!> ocean_model_init initializes the ocean model, including registering fields -!! for restarts and reading restart files if appropriate. -!! -!! This subroutine initializes both the ocean state and the ocean surface type. -!! Because of the way that indicies and domains are handled, Ocean_sfc must have -!! been used in a previous call to cean_type. +!! This subroutine initializes the stochastics physics control structure. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] type(ocean_grid_type), intent(in) :: grid ! horizontal grid information @@ -135,6 +124,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) write(*,'(/12x,a/)') '=== COMPLETED MOM STOCHASTIC INITIALIZATION =====' call callTree_leave("ocean_model_init(") + return end subroutine stochastics_init !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 index 89a6d43c4f..349d56c0c7 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 @@ -3,13 +3,11 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. -! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, termination and update of ocean model state. This -! particular version wraps all of the calls for MOM6 in the calls that had -! been used for MOM4. -! -! This code is a stop-gap wrapper of the MOM6 code to enable it to be called -! in the same way as MOM4. +! This is the top level module for the MOM6 ocean model. It contains +! placeholder for initialization, update, and writing restarts of ocean stochastic physics. +! The actualy stochastic physics is available at +! https://github.com/ufs-community/ufs-weather-model +! use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type @@ -62,6 +60,9 @@ subroutine update_stochastics(CS) type(stochastic_CS), intent(inout) :: CS !< diabatic control structure return end subroutine update_stochastics - +subroutine write_mom_restart_stoch(filename) + character(len=*) :: filename + return +end subroutine write_mom_restart_stoch end module MOM_stochastics diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 71009d225d..b331c64174 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -662,7 +662,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call disable_averaging(CS%diag) endif endif - + ! advance the random pattern if stochastic physics is active if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then @@ -2495,8 +2495,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (.not. CS%rotate_index) & G => G_in - ! initialize stochastic physics - !call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index ffbbd2c7d1..044071dc38 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -313,7 +313,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (G%ke == 1) return - ! save copy of the date for SPPT + ! save copy of the date for SPPT if active if (stoch_CS%do_sppt) then allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) From 9221b5d50180c365a951d7672e94ad39533c9dd8 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Mon, 16 Aug 2021 08:53:19 -0400 Subject: [PATCH 028/155] update to gfdl 20210806 (#74) * remove white space and fix comment * Update MOM_oda_incupd.F90 remove unused index bounds, and fix sum_h2 loop. Co-authored-by: pjpegion Co-authored-by: Marshall Ward --- src/ocean_data_assim/MOM_oda_incupd.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 8b93582e4b..ab3621296f 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -416,7 +416,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo endif enddo; enddo - + ! remap u to h_obs to get increment if (CS%uv_inc) then call pass_var(h, G%Domain) From 348a81b630502e17f0566edde8f37d457548f9a4 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 21 Sep 2021 18:54:31 -0800 Subject: [PATCH 029/155] Several little things, one is making sponge less verbose. - Pointing to OBC wiki file from the lateral parameterizations doc. - Using the MOM6 verbosity to control the time_interp verbosity. - Making the check for negative water depths more informative. --- src/framework/MOM_horizontal_regridding.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index de511688a9..1204fc21b1 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -740,7 +740,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=(verbosity>5), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>2), 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 @@ -840,6 +840,14 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + ! now fill in missing values using "ICE-nine" algorithm. + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) + + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) ! endif @@ -856,7 +864,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=(verbosity>5), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>2), turns=turns) do k=1,kd do j=js,je do i=is,ie @@ -867,6 +875,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo enddo endif + end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. From c3ff425ce1bf31b7f4a98b389872ef91c6707f4b Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 28 Sep 2021 18:47:57 +0000 Subject: [PATCH 030/155] return a more accurate error message in MOM_stochasics --- .../external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 427b3c754b..e6b0c80280 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -101,9 +101,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then - write(6,*) 'call to init_stochastic_physics_ocn failed' - call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & - "not activated in stochastic_physics namelist ") + call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") return endif From b7b4141a606c164f6d6d9c29710bd19c705a39ae Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Oct 2021 10:57:33 -0800 Subject: [PATCH 031/155] Working on boundary layer docs. --- src/framework/MOM_horizontal_regridding.F90 | 4 +- src/parameterizations/vertical/_EPBL.dox | 184 +------------------- 2 files changed, 5 insertions(+), 183 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1204fc21b1..e5e651407e 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -740,7 +740,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=(verbosity>2), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. do k=1,kd @@ -864,7 +864,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=(verbosity>2), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/parameterizations/vertical/_EPBL.dox b/src/parameterizations/vertical/_EPBL.dox index d531c9ad9a..6134de31e0 100644 --- a/src/parameterizations/vertical/_EPBL.dox +++ b/src/parameterizations/vertical/_EPBL.dox @@ -57,7 +57,7 @@ Similarly, the eddy diffusivity is used to parameterize turbulent scalar fluxes \f] The parameters needed to close the system of equations are then reduced to the turbulent -mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$. +mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$$. We start with an equation for the turbulent kinetic energy (TKE): @@ -67,188 +67,10 @@ We start with an equation for the turbulent kinetic energy (TKE): {\partial z} + \overline{w^\prime b^\prime} - \epsilon \f] + Terms in this equation represent TKE storage (LHS), TKE flux convergence, shear production, buoyancy production, and dissipation. -\section section_WMBL Well-mixed Boundary Layers (WMBL) - -Assuming steady state and other parameterizations, integrating vertically -over the surface boundary layer, \cite reichl2018 obtains the form: - -\f[ - \frac{1}{2} H_{bl} w_e \Delta b = m_\ast u_\ast^3 - n_\ast \frac{H_{bl}}{2} - B(H_{bl}) , -\f] - -with the following variables: - - - -
Symbols used in integrated TKE equation
Symbol Meaning -
\f$H_{bl}\f$ boundary layer thickness -
\f$w_e\f$ entrainment velocity -
\f$\Delta b\f$ change in buoyancy at base of mixed layer -
\f$m_\ast\f$ sum of mechanical coefficients -
\f$u_\ast\f$ friction velocity (\f$u_\ast = (|\tau| / \rho_0)^{1/2}\f$) -
\f$\tau\f$ wind stress -
\f$n_\ast\f$ convective proportionality coefficient -
1 for stabilizing surface buoyancy flux, less otherwise -
\f$B(H_{bl})\f$ surface buoyancy flux -
- -\section section_ePBL Energetics-based Planetary Boundary Layer - -Once again, the goal is to formulate a surface mixing scheme to find the -turbulent eddy diffusivity (and viscosity) in a way that is suitable for use -in a global climate model, using long timesteps and large grid spacing. -After evaluating a well-mixed boundary layer (WMBL), the shear mixing of -\cite jackson2008 (JHL, \ref subsection_kappa_shear), as well as a more complete -boundary layer scheme, it was decided to combine a number of these ideas -into a new scheme: - -\f[ - K(z) = F_x(K_{ePBL}(z), K_{JHL}(z), K_n(z)) -\f] - -where \f$F_x\f$ is some unknown function of a new \f$K_{ePBL}\f$, -\f$K_{JHL}\f$, the diffusivity due to shear as determined by -\cite jackson2008, and \f$K_n\f$, the diffusivity from other ideas. -We start by specifying the form of \f$K_{ePBL}\f$ as being: - -\f[ - K_{ePBL}(z) = C_K w_t l , -\f] - -where \f$w_t\f$ is a turbulent velocity scale, \f$C_K\f$ is a coefficient, and -\f$l\f$ is a length scale. - -\subsection subsection_lengthscale Turbulent length scale - -We propose a form for the length scale as follows: - -\f[ - l = (z_0 + |z|) \times \max \left[ \frac{l_b}{H_{bl}} , \left( - \frac{H_{bl} - |z|}{H_{bl}} \right)^\gamma \, \right] , -\f] - -where we have the following variables: - - - -
Symbols used in ePBL length scale
Symbol Meaning -
\f$H_{bl}\f$ boundary layer thickness -
\f$z_0\f$ roughness length -
\f$\gamma\f$ coefficient, 2 is as in KPP, \cite large1994 -
\f$l_b\f$ bottom length scale -
- -\subsection subsection_velocityscale Turbulent velocity scale - -We do not predict the TKE prognostically and therefore approximate the vertical TKE -profile to estimate \f$w_t\f$. An estimate for the mechanical contribution to the velocity -scale follows the standard two-equation approach. In one and two-equation second-order -\f$K\f$ parameterizations the boundary condition for the TKE is typically employed as a -flux boundary condition. - -\f[ - K \left. \frac{\partial k}{\partial z} \right|_{z=0} = c_\mu^0 u_\ast^3 . -\f] - -The profile of \f$k\f$ decays in the vertical from \f$k \propto (c_\mu^0)^{2/3} -u_\ast^2\f$ toward the base of the OSBL. Here we assume a similar relationship to estimate -the mechanical contribution to the TKE profile. The value of \f$w_t\f$ due to mechanical -sources, \f$v_\ast\f$, is estimate as \f$v_\ast (z=0) \propto (c_\mu^0)^{1/3} u_\ast\f$ at -the surface. Since we only parameterize OSBL turbulent mixing due to surface forcing, the -value of the velocity scale is assumed to decay moving away from the surface. For -simplicity we employ a linear decay in depth: - -\f[ - v_\ast (z) = (c_\mu^0)^{1/3} u_\ast \left( 1 - a \cdot \min \left[ 1, - \frac{|z|}{H_{bl}} \right] \right) , -\f] - -where \f$1 > a > 0\f$ has the effect of making \f$v_\ast(z=H_{bl}) > 0\f$. -Making the constant coefficient \f$a\f$ close to one has the effect of reducing the mixing -rate near the base of the boundary layer, thus producing a more diffuse entrainment -region. Making \f$a\f$ close to zero has the effect of increasing the mixing at the base -of the boundary layer, producing a more 'step-like' entrainment region. - -An estimate for the buoyancy contribution is found utilizing the convective velocity -scale: - -\f[ - w_\ast (z) = C_{w_\ast} \left( \int_z^0 \overline{w^\prime b^\prime} dz \right)^{1/3} , -\f] - -where \f$C_{w_\ast}\f$ is a non-dimensional empirical coefficient. Convection in one and -two-equation closure causes a TKE profile that peaks below the surface. The quantity -\f$\overline{w^\prime b^\prime}\f$ is solved for in ePBL as \f$KN^2\f$. - -These choices for the convective and mechanical components of the velocity scale in the -OSBL are then added together to get an estimate for the total turbulent velocity scale: - -\f[ - w_t (z) = w_\ast (z) + v_\ast (z) . -\f] - -The value of \f$a\f$ is arbitrarily chosen to be 0.95 here. - -\subsection subsection_ePBL_summary Summarizing the ePBL implementation - -The ePBL mixing coefficient is found by multiplying a velocity scale -(\ref subsection_velocityscale) by a length scale (\ref subsection_lengthscale). The -precise value of the coefficient \f$C_K\f$ used does not significantly alter the -prescribed potential energy change constraint. A reasonable value is \f$C_K \approx 0.55\f$ to -be consistent with other approaches (e.g. \cite umlauf2005). - -The boundary layer thickness (\f$H_{bl}\f$) within ePBL is based on -the depth where the energy requirement for turbulent mixing of density -exceeds the available energy (\ref section_WMBL). \f$H_{bl}\f$ is -determined by the energetic constraint imposed using the value of -\f$m_\ast\f$ and \f$n_\ast\f$. An iterative solver is required because -\f$m_\ast\f$ and the mixing length are dependent on \f$H_{bl}\f$. - -We use a constant value for convectively driven TKE of \f$n_\ast = 0.066\f$. The -parameterizations for \f$m_\ast\f$ are formulated specifically for the regimes where -\f$K_{JHL}\f$ is sensitive to model numerics \f$(|f| \Delta t \approx -1)\f$ (\cite reichl2018). - -\subsection subsection_ePBL_JHL Combining ePBL and JHL mixing coefficients - -We now address the combination of the ePBL mixing coefficient and the JHL mixing -coefficient. The function \f$F_x\f$ above cannot be the linear sum of \f$K_{ePBL}\f$ and -\f$K_{JHL}\f$. One reason this sum is not valid is because the JHL mixing coefficient is -determined by resolved current shear, including that driven by the surface wind. The -wind-driven current is also included in the ePBL mixing coefficient formulation. An -alternative approach is therefore needed to avoid double counting. - -\f$K_{ePBL}\f$ is not used at the equator as scalings are only investigated when \f$|f| > -0\f$. The solution we employ is to use the maximum mixing coefficient of the two -contributions, - -\f[ - K (z) = \max (K_{ePBL} (z), K_{JHL} (z)), -\f] - -where \f$m_\ast\f$ (and hence \f$K_{ePBL}\f$) is constrained to be small as \f$|f| -\rightarrow 0\f$. This form uses the JHL mixing coefficient when the ePBL coefficient is -small. - -This approach is reasonable when the wind-driven mixing dominates, since both JHL and ePBL -give a similar solution when deployed optimally. One weakness of this approach is the -tropical region, where the shear-driven ePBL \f$m_\ast\f$ coefficient is not formulated. -The JHL parameterization is skillful to simulate this mixing, but does not include the -contribution of convection. The convective portion of \f$K_{ePBL}\f$ should be combined -with \f$K_{JHL}\f$ in the equatorial region when shear and convection occur together. -Future research is warranted. - -Finally, one should note that the mixing coefficient here (\f$K\f$) is used for both -diffusivity and viscosity, implying a turbulent Prandtl number of 1.0. - -\subsection subsection_Langmuir Langmuir circulation - -While only briefly alluded to in \cite reichl2018, the MOM6 code implementing ePBL does -support the option to add a Langmuir parameterization. There are in fact two options, both -adjusting \f$m_\ast\f$. +Following the lead of \cite jackson2008 (\ref subsection_kappa_shear). */ From 71908c8fd30b08a6ffb43ba655ed6c4e6cc1e70f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Oct 2021 13:46:54 -0800 Subject: [PATCH 032/155] Done with EPBL docs? --- docs/conf.py | 2 +- src/parameterizations/vertical/_EPBL.dox | 184 ++++++++++++++++++++++- 2 files changed, 182 insertions(+), 4 deletions(-) diff --git a/docs/conf.py b/docs/conf.py index 4407d88356..5d84b3c37a 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -159,7 +159,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # General information about the project. project = u'MOM6' -copyright = u'2017-2022, MOM6 developers' +copyright = u'2017-2021, MOM6 developers' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the diff --git a/src/parameterizations/vertical/_EPBL.dox b/src/parameterizations/vertical/_EPBL.dox index 6134de31e0..d531c9ad9a 100644 --- a/src/parameterizations/vertical/_EPBL.dox +++ b/src/parameterizations/vertical/_EPBL.dox @@ -57,7 +57,7 @@ Similarly, the eddy diffusivity is used to parameterize turbulent scalar fluxes \f] The parameters needed to close the system of equations are then reduced to the turbulent -mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$$. +mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$. We start with an equation for the turbulent kinetic energy (TKE): @@ -67,10 +67,188 @@ We start with an equation for the turbulent kinetic energy (TKE): {\partial z} + \overline{w^\prime b^\prime} - \epsilon \f] - Terms in this equation represent TKE storage (LHS), TKE flux convergence, shear production, buoyancy production, and dissipation. -Following the lead of \cite jackson2008 (\ref subsection_kappa_shear). +\section section_WMBL Well-mixed Boundary Layers (WMBL) + +Assuming steady state and other parameterizations, integrating vertically +over the surface boundary layer, \cite reichl2018 obtains the form: + +\f[ + \frac{1}{2} H_{bl} w_e \Delta b = m_\ast u_\ast^3 - n_\ast \frac{H_{bl}}{2} + B(H_{bl}) , +\f] + +with the following variables: + + + +
Symbols used in integrated TKE equation
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$w_e\f$ entrainment velocity +
\f$\Delta b\f$ change in buoyancy at base of mixed layer +
\f$m_\ast\f$ sum of mechanical coefficients +
\f$u_\ast\f$ friction velocity (\f$u_\ast = (|\tau| / \rho_0)^{1/2}\f$) +
\f$\tau\f$ wind stress +
\f$n_\ast\f$ convective proportionality coefficient +
1 for stabilizing surface buoyancy flux, less otherwise +
\f$B(H_{bl})\f$ surface buoyancy flux +
+ +\section section_ePBL Energetics-based Planetary Boundary Layer + +Once again, the goal is to formulate a surface mixing scheme to find the +turbulent eddy diffusivity (and viscosity) in a way that is suitable for use +in a global climate model, using long timesteps and large grid spacing. +After evaluating a well-mixed boundary layer (WMBL), the shear mixing of +\cite jackson2008 (JHL, \ref subsection_kappa_shear), as well as a more complete +boundary layer scheme, it was decided to combine a number of these ideas +into a new scheme: + +\f[ + K(z) = F_x(K_{ePBL}(z), K_{JHL}(z), K_n(z)) +\f] + +where \f$F_x\f$ is some unknown function of a new \f$K_{ePBL}\f$, +\f$K_{JHL}\f$, the diffusivity due to shear as determined by +\cite jackson2008, and \f$K_n\f$, the diffusivity from other ideas. +We start by specifying the form of \f$K_{ePBL}\f$ as being: + +\f[ + K_{ePBL}(z) = C_K w_t l , +\f] + +where \f$w_t\f$ is a turbulent velocity scale, \f$C_K\f$ is a coefficient, and +\f$l\f$ is a length scale. + +\subsection subsection_lengthscale Turbulent length scale + +We propose a form for the length scale as follows: + +\f[ + l = (z_0 + |z|) \times \max \left[ \frac{l_b}{H_{bl}} , \left( + \frac{H_{bl} - |z|}{H_{bl}} \right)^\gamma \, \right] , +\f] + +where we have the following variables: + + + +
Symbols used in ePBL length scale
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$z_0\f$ roughness length +
\f$\gamma\f$ coefficient, 2 is as in KPP, \cite large1994 +
\f$l_b\f$ bottom length scale +
+ +\subsection subsection_velocityscale Turbulent velocity scale + +We do not predict the TKE prognostically and therefore approximate the vertical TKE +profile to estimate \f$w_t\f$. An estimate for the mechanical contribution to the velocity +scale follows the standard two-equation approach. In one and two-equation second-order +\f$K\f$ parameterizations the boundary condition for the TKE is typically employed as a +flux boundary condition. + +\f[ + K \left. \frac{\partial k}{\partial z} \right|_{z=0} = c_\mu^0 u_\ast^3 . +\f] + +The profile of \f$k\f$ decays in the vertical from \f$k \propto (c_\mu^0)^{2/3} +u_\ast^2\f$ toward the base of the OSBL. Here we assume a similar relationship to estimate +the mechanical contribution to the TKE profile. The value of \f$w_t\f$ due to mechanical +sources, \f$v_\ast\f$, is estimate as \f$v_\ast (z=0) \propto (c_\mu^0)^{1/3} u_\ast\f$ at +the surface. Since we only parameterize OSBL turbulent mixing due to surface forcing, the +value of the velocity scale is assumed to decay moving away from the surface. For +simplicity we employ a linear decay in depth: + +\f[ + v_\ast (z) = (c_\mu^0)^{1/3} u_\ast \left( 1 - a \cdot \min \left[ 1, + \frac{|z|}{H_{bl}} \right] \right) , +\f] + +where \f$1 > a > 0\f$ has the effect of making \f$v_\ast(z=H_{bl}) > 0\f$. +Making the constant coefficient \f$a\f$ close to one has the effect of reducing the mixing +rate near the base of the boundary layer, thus producing a more diffuse entrainment +region. Making \f$a\f$ close to zero has the effect of increasing the mixing at the base +of the boundary layer, producing a more 'step-like' entrainment region. + +An estimate for the buoyancy contribution is found utilizing the convective velocity +scale: + +\f[ + w_\ast (z) = C_{w_\ast} \left( \int_z^0 \overline{w^\prime b^\prime} dz \right)^{1/3} , +\f] + +where \f$C_{w_\ast}\f$ is a non-dimensional empirical coefficient. Convection in one and +two-equation closure causes a TKE profile that peaks below the surface. The quantity +\f$\overline{w^\prime b^\prime}\f$ is solved for in ePBL as \f$KN^2\f$. + +These choices for the convective and mechanical components of the velocity scale in the +OSBL are then added together to get an estimate for the total turbulent velocity scale: + +\f[ + w_t (z) = w_\ast (z) + v_\ast (z) . +\f] + +The value of \f$a\f$ is arbitrarily chosen to be 0.95 here. + +\subsection subsection_ePBL_summary Summarizing the ePBL implementation + +The ePBL mixing coefficient is found by multiplying a velocity scale +(\ref subsection_velocityscale) by a length scale (\ref subsection_lengthscale). The +precise value of the coefficient \f$C_K\f$ used does not significantly alter the +prescribed potential energy change constraint. A reasonable value is \f$C_K \approx 0.55\f$ to +be consistent with other approaches (e.g. \cite umlauf2005). + +The boundary layer thickness (\f$H_{bl}\f$) within ePBL is based on +the depth where the energy requirement for turbulent mixing of density +exceeds the available energy (\ref section_WMBL). \f$H_{bl}\f$ is +determined by the energetic constraint imposed using the value of +\f$m_\ast\f$ and \f$n_\ast\f$. An iterative solver is required because +\f$m_\ast\f$ and the mixing length are dependent on \f$H_{bl}\f$. + +We use a constant value for convectively driven TKE of \f$n_\ast = 0.066\f$. The +parameterizations for \f$m_\ast\f$ are formulated specifically for the regimes where +\f$K_{JHL}\f$ is sensitive to model numerics \f$(|f| \Delta t \approx +1)\f$ (\cite reichl2018). + +\subsection subsection_ePBL_JHL Combining ePBL and JHL mixing coefficients + +We now address the combination of the ePBL mixing coefficient and the JHL mixing +coefficient. The function \f$F_x\f$ above cannot be the linear sum of \f$K_{ePBL}\f$ and +\f$K_{JHL}\f$. One reason this sum is not valid is because the JHL mixing coefficient is +determined by resolved current shear, including that driven by the surface wind. The +wind-driven current is also included in the ePBL mixing coefficient formulation. An +alternative approach is therefore needed to avoid double counting. + +\f$K_{ePBL}\f$ is not used at the equator as scalings are only investigated when \f$|f| > +0\f$. The solution we employ is to use the maximum mixing coefficient of the two +contributions, + +\f[ + K (z) = \max (K_{ePBL} (z), K_{JHL} (z)), +\f] + +where \f$m_\ast\f$ (and hence \f$K_{ePBL}\f$) is constrained to be small as \f$|f| +\rightarrow 0\f$. This form uses the JHL mixing coefficient when the ePBL coefficient is +small. + +This approach is reasonable when the wind-driven mixing dominates, since both JHL and ePBL +give a similar solution when deployed optimally. One weakness of this approach is the +tropical region, where the shear-driven ePBL \f$m_\ast\f$ coefficient is not formulated. +The JHL parameterization is skillful to simulate this mixing, but does not include the +contribution of convection. The convective portion of \f$K_{ePBL}\f$ should be combined +with \f$K_{JHL}\f$ in the equatorial region when shear and convection occur together. +Future research is warranted. + +Finally, one should note that the mixing coefficient here (\f$K\f$) is used for both +diffusivity and viscosity, implying a turbulent Prandtl number of 1.0. + +\subsection subsection_Langmuir Langmuir circulation + +While only briefly alluded to in \cite reichl2018, the MOM6 code implementing ePBL does +support the option to add a Langmuir parameterization. There are in fact two options, both +adjusting \f$m_\ast\f$. */ From 3dbf2f58dc29898492f1a9b72e80d1454685f1b1 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Oct 2021 14:53:52 -0800 Subject: [PATCH 033/155] Undoing some patches from others --- src/core/MOM_barotropic.F90 | 32 +++------------------ src/framework/MOM_horizontal_regridding.F90 | 9 ------ 2 files changed, 4 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3cb1ebf399..cf001fc1d0 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -225,10 +225,7 @@ module MOM_barotropic !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. logical :: tides !< If true, apply tidal momentum forcing. - logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the - !! barotropic solver has the wrong sign, replicating a long-standing - !! bug. - real :: G_extra !< A nondimensional factor by which gtot is enhanced [nondim]. + real :: G_extra !< A nondimensional factor by which gtot is enhanced. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are !! given by the parameters defined below: @@ -1057,11 +1054,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%tides) then call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - if (CS%tidal_sal_bug) then - dgeo_de = 1.0 + det_de + CS%G_extra - else - dgeo_de = (1.0 - det_de) + CS%G_extra - endif + dgeo_de = 1.0 + det_de + CS%G_extra else dgeo_de = 1.0 + CS%G_extra endif @@ -2804,11 +2797,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) det_de = 0.0 if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - if (CS%tidal_sal_bug) then - dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) - else - dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de) - endif + dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) if (present(pbce)) then do j=js,je ; do i=is,ie gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 @@ -4299,12 +4288,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. - real :: det_de ! The partial derivative due to self-attraction and loading of the reference - ! geopotential with the sea surface height when tides are enabled. - ! This is typically ~0.09 or less. - real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points - ! that acts on the barotropic flow [Z T-1 ~> m s-1]. - + real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity @@ -4458,14 +4442,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) - det_de = 0.0 - if (CS%tides .and. associated(CS%tides_CSp)) & - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & - "If true, the tidal self-attraction and loading anomaly in the barotropic "//& - "solver has the wrong sign, replicating a long-standing bug with a scalar "//& - "self-attraction and loading term or the SAL term from a previous simulation.", & - default=.true., do_not_log=(det_de==0.0)) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index e5e651407e..de511688a9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -840,14 +840,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) - ! now fill in missing values using "ICE-nine" algorithm. - tr_outf(:,:) = tr_out(:,:) - if (k==1) tr_prev(:,:) = tr_outf(:,:) - good2(:,:) = good(:,:) - fill2(:,:) = fill(:,:) - - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) - ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) ! endif @@ -875,7 +867,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo enddo endif - end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. From 45d6151916f0d3d064bab5aefe15513bc4b2ebcb Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 12 Oct 2021 11:01:28 -0800 Subject: [PATCH 034/155] Adding in that SAL commit again. --- src/core/MOM_barotropic.F90 | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index cf001fc1d0..9ee023c546 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -225,6 +225,9 @@ module MOM_barotropic !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. logical :: tides !< If true, apply tidal momentum forcing. + logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the + !! barotropic solver has the wrong sign, replicating a long-standing + !! bug. real :: G_extra !< A nondimensional factor by which gtot is enhanced. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are @@ -1054,7 +1057,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%tides) then call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - dgeo_de = 1.0 + det_de + CS%G_extra + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + det_de + CS%G_extra + else + dgeo_de = (1.0 - det_de) + CS%G_extra + endif else dgeo_de = 1.0 + CS%G_extra endif @@ -2797,7 +2804,11 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) det_de = 0.0 if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) + else + dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de) + endif if (present(pbce)) then do j=js,je ; do i=is,ie gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 @@ -4288,6 +4299,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. + real :: det_de ! The partial derivative due to self-attraction and loading of the reference + ! geopotential with the sea surface height when tides are enabled. + ! This is typically ~0.09 or less. real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4442,6 +4456,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + det_de = 0.0 + if (CS%tides .and. associated(CS%tides_CSp)) & + call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & + "If true, the tidal self-attraction and loading anomaly in the barotropic "//& + "solver has the wrong sign, replicating a long-standing bug with a scalar "//& + "self-attraction and loading term or the SAL term from a previous simulation.", & + default=.true., do_not_log=(det_de==0.0)) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& From 65cccb7a04d17b2f9a1af89240ef9ab287d947cb Mon Sep 17 00:00:00 2001 From: jiandewang Date: Thu, 28 Oct 2021 15:47:25 -0400 Subject: [PATCH 035/155] correction on type in directory name --- .../MOM_stochastics.F90 | 0 .../MOM_stochastics_stub.F90 | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename config_src/external/{OCEAN_stochastic_phyiscs => OCEAN_stochastic_physics}/MOM_stochastics.F90 (100%) rename config_src/external/{OCEAN_stochastic_phyiscs => OCEAN_stochastic_physics}/MOM_stochastics_stub.F90 (100%) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 similarity index 100% rename from config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 rename to config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 similarity index 100% rename from config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 rename to config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 From ebb643af955320dbfc581da4377cb3290a0215e8 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 28 Jan 2022 11:24:39 -0900 Subject: [PATCH 036/155] Oops, more cleanup. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 17 +-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 19 ++-- config_src/drivers/solo_driver/MOM_driver.F90 | 14 --- .../MOM_stochastics_stub.F90 | 68 ------------ docs/conf.py | 2 +- src/core/MOM.F90 | 37 ++++--- src/core/MOM_barotropic.F90 | 6 +- src/diagnostics/MOM_diagnostics.F90 | 4 +- src/framework/MOM_domains.F90 | 60 ++++++++--- .../stochastic}/MOM_stochastics.F90 | 35 +++--- .../vertical/MOM_diabatic_driver.F90 | 63 +++++------ .../vertical/MOM_energetic_PBL.F90 | 102 +++++++----------- 12 files changed, 167 insertions(+), 260 deletions(-) delete mode 100644 config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 rename {config_src/external/OCEAN_stochastic_physics => src/parameterizations/stochastic}/MOM_stochastics.F90 (86%) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 25de32d526..174a659f12 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -98,7 +98,6 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -use MOM_stochastics, only : write_mom_restart_stoch !$use omp_lib , only : omp_set_num_threads implicit none; private @@ -1750,21 +1749,9 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + call ocean_model_restart(ocean_state, restartname=restartname, & + stoch_restartname=stoch_restartname) - if (ocean_state%do_sppt .OR. ocean_state%pert_epbl) then - if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc" - else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" - endif - call ESMF_LogWrite("MOM_cap: Writing stoch restart : "//trim(restartname), & - ESMF_LOGMSG_INFO) - call write_mom_restart_stoch('RESTART/'//trim(restartname)) - endif - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - call write_stoch_restart_ocn('RESTART/'//trim(restartname)) endif if (is_root_pe()) then diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 9ffe4cd794..448f23140e 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -62,8 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,num_PEs -use MOM_coms, only : Get_PElist +use get_stochy_pattern_mod, only : write_stoch_restart_ocn +use iso_fortran_env, only : int64 #include @@ -177,8 +177,10 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical,public :: do_sppt !< If true, write stochastic physics restarts - logical,public :: pert_epbl !< If true, write stochastic physics restarts + logical :: do_sppt !< If true, stochastically perturb the diabatic and + !! write restarts + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and + !! genration termsand write restarts real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -253,7 +255,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot!< If true, allocate melt_potential array + logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: use_CFC !< If true, allocated arrays for surface CFCs. + ! This include declares and sets the variable "version". #include "version_variable.h" @@ -425,10 +429,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - ! check to see if stochastic physics is active + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) +! get number of processors and PE list for stocasthci physics initialization call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "tendencies of T,S, and h. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index afb1901e0a..1b88f1ce36 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -69,19 +69,6 @@ program MOM_main use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS - 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 - use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart -! , add_shelf_flux_forcing, add_shelf_flux_IOB - - 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 #include @@ -91,7 +78,6 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes - ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state diff --git a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 deleted file mode 100644 index 349d56c0c7..0000000000 --- a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 +++ /dev/null @@ -1,68 +0,0 @@ -!> Top-level module for the MOM6 ocean model in coupled mode. -module MOM_stochastics - -! This file is part of MOM6. See LICENSE.md for the license. - -! This is the top level module for the MOM6 ocean model. It contains -! placeholder for initialization, update, and writing restarts of ocean stochastic physics. -! The actualy stochastic physics is available at -! https://github.com/ufs-community/ufs-weather-model -! - -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -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 MOM_domains, only : root_PE,num_PEs -use MOM_coms, only : Get_PElist - -#include - -implicit none ; private - -public stochastics_init, update_stochastics - -!> This control structure holds parameters for the MOM_stochastics module -type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - !>@{ Diagnostic IDs - integer :: id_sppt_wts = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 - !>@} - ! stochastic patterns - real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - !! tendencies with a number between 0 and 2 - real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation - real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output - type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) -end type stochastic_CS - -contains - -subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) - real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid ! horizontal grid information - type(verticalGrid_type), intent(in) :: GV ! vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output - type(time_type), target :: Time !< model time - return -end subroutine stochastics_init - -subroutine update_stochastics(CS) - type(stochastic_CS), intent(inout) :: CS !< diabatic control structure - return -end subroutine update_stochastics -subroutine write_mom_restart_stoch(filename) - character(len=*) :: filename - return -end subroutine write_mom_restart_stoch -end module MOM_stochastics - diff --git a/docs/conf.py b/docs/conf.py index 5d84b3c37a..4407d88356 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -159,7 +159,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # General information about the project. project = u'MOM6' -copyright = u'2017-2021, MOM6 developers' +copyright = u'2017-2022, MOM6 developers' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b331c64174..c36c0545e1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -132,7 +132,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state, stochastic_pattern +use MOM_variables, only : rotate_surface_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -154,6 +154,8 @@ 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, initialize_ice_shelf +use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end implicit none ; private @@ -402,6 +404,16 @@ module MOM type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling !! ensemble model state vectors and data assimilation !! increments and priors + type(porous_barrier_ptrs) :: pbv !< porous barrier fractional cell metrics + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) & + :: por_face_areaU !< fractional open area of U-faces [nondim] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) & + :: por_face_areaV !< fractional open area of V-faces [nondim] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) & + :: por_layer_widthU !< fractional open width of U-faces [nondim] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) & + :: por_layer_widthV !< fractional open width of V-faces [nondim] + type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure end type MOM_control_struct @@ -1381,7 +1393,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS,OBC=CS%OBC, Waves=Waves) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1799,7 +1811,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - real :: conv2watt, conv2salt + real :: conv2watt ! A conversion factor from temperature fluxes to heat + ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] + real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -2475,28 +2490,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif - ! Shift from using the temporary dynamic grid type to using the final - ! (potentially static) ocean-specific grid type. - ! The next line would be needed if G%Domain had not already been init'd above: - ! call clone_MOM_domain(dG%Domain, G%Domain) - call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG, G, US) - call destroy_dyn_horgrid(dG) - ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) else call set_first_direction(G, modulo(first_direction, 2)) endif - call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) - call destroy_dyn_horgrid(dG_in) - - if (.not. CS%rotate_index) & - G => G_in - ! Set a few remaining fields that are specific to the ocean grid type. - call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9ee023c546..3cb1ebf399 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -228,7 +228,7 @@ module MOM_barotropic logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the !! barotropic solver has the wrong sign, replicating a long-standing !! bug. - real :: G_extra !< A nondimensional factor by which gtot is enhanced. + real :: G_extra !< A nondimensional factor by which gtot is enhanced [nondim]. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are !! given by the parameters defined below: @@ -4302,7 +4302,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, real :: det_de ! The partial derivative due to self-attraction and loading of the reference ! geopotential with the sea surface height when tides are enabled. ! This is typically ~0.09 or less. - real, allocatable, dimension(:,:) :: lin_drag_h + real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points + ! that acts on the barotropic flow [Z T-1 ~> m s-1]. + type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e0b0d4469b..8d667503d7 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1286,8 +1286,8 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> s]. type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< Time mean surface height without corrections + !! for ice displacement [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 2b30a4d629..0cdcc455fc 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,24 +3,56 @@ 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_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, group_pass_type +use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain +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 +use MOM_domain_infra, only : start_group_pass, complete_group_pass +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 +use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io_infra, only : file_exists use MOM_string_functions, only : slasher 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 :: 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 :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER +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 +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! Domain query routines +public :: get_domain_extent, get_domain_components, get_global_shape, same_domain +public :: PE_here, root_PE, num_PEs +! Blocks are not actively used in MOM6, so this routine could be deprecated. +public :: compute_block_extent +! 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 :: 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 +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. diff --git a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 similarity index 86% rename from config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 rename to src/parameterizations/stochastic/MOM_stochastics.F90 index e6b0c80280..21a22a222e 100644 --- a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -19,20 +19,20 @@ module MOM_stochastics use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn -use get_stochy_pattern_mod, only: write_stoch_restart_ocn #include implicit none ; private -public stochastics_init, update_stochastics, write_mom_restart_stoch +public stochastics_init, update_stochastics !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT + integer :: id_epbl1_wts=-1 !< Diagnostic id for epbl generation perturbation + integer :: id_epbl2_wts=-1 !< Diagnostic id for epbl dissipation perturbation ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 @@ -47,9 +47,9 @@ module MOM_stochastics !! This subroutine initializes the stochastics physics control structure. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid ! horizontal grid information - type(verticalGrid_type), intent(in) :: GV ! vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS + type(ocean_grid_type), intent(in) :: grid !< horizontal grid information + type(verticalGrid_type), intent(in) :: GV !< vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS !< stochastic control structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(time_type), target :: Time !< model time @@ -59,7 +59,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics integer :: me ! my pe - integer :: master ! root pe + integer :: pe_zero ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo @@ -95,11 +95,11 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - master=root_PE() + pe_zero=root_PE() nx = grid%ied - grid%isd + 1 ny = grid%jed - grid%jsd + 1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) + CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) if (iret/=0) then call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") return @@ -140,16 +140,5 @@ subroutine update_stochastics(CS) return end subroutine update_stochastics -!< wrapper to write ocean stochastic restarts -subroutine write_mom_restart_stoch(filename) - character(len=*) :: filename - - call callTree_enter("write_mom_restart_stoch(), MOM_stochastics.F90") - - call write_stoch_restart_ocn(filename) - - return -end subroutine write_mom_restart_stoch - end module MOM_stochastics diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 044071dc38..5eaca3c275 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -71,7 +71,6 @@ module MOM_diabatic_driver use MOM_wave_interface, only : wave_parameters_CS use MOM_stochastics, only : stochastic_CS - implicit none ; private #include @@ -221,8 +220,6 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics - real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil - real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module @@ -283,8 +280,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -293,8 +291,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -305,9 +303,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable(:,:,:) :: s_in ! salinity before thermodynamics + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT @@ -327,7 +325,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + if (GV%ke == 1) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") @@ -504,12 +504,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo enddo + deallocate(h_in) + deallocate(t_in) + deallocate(s_in) endif end subroutine diabatic -end subroutine diabatic - !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. @@ -523,10 +524,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] - type(forcing), intent(inout) :: fluxes !< points to forcing fields - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -534,7 +537,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -835,8 +838,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves) + CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -1111,8 +1113,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -1120,7 +1123,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1372,8 +1375,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves) + CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) @@ -3136,12 +3138,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & - 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & - 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & - 'random pattern for sppt', 'None') + if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + if ((CS%id_dvdt_dia > 0) .or. (CS%id_hf_dvdt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 9ecba8a7b8..99dd38135d 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -244,9 +244,8 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, & - last_call, dT_expected, dS_expected, Waves) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) 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 @@ -278,27 +277,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 s-1 ~> m2 s-1]. - type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous - !! call to mixedlayer_init. + !! [Z2 T-1 ~> m2 s-1]. + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. - real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less - !! than dt if there are two calls to mixedlayer [T ~> s]. - logical, optional, intent(in) :: last_call !< If true, this is the last call to - !! mixedlayer in the current time step, so - !! diagnostics will be written. The default - !! is .true. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dT_expected !< The values of temperature change that - !! should be expected when the returned - !! diffusivities are applied [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dS_expected !< The values of salinity change that - !! should be expected when the returned - !! diffusivities are applied [ppt]. - type(wave_parameters_CS), & - optional, pointer :: Waves !< Wave CS + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous ! This subroutine determines the diffusivities from the integrated energetics @@ -439,16 +422,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) + if (stoch_CS%pert_epbl) then ! stochastics are active call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j), & - i=i, j=j) + US, CS, eCD, Waves, G, i, j, & + epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + US, CS, eCD, Waves, G, i, j) endif ! Copy the diffusivities to a 2-d array. @@ -488,30 +471,26 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS enddo ! j-loop - if (write_diags) then - if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) - if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) - if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) - if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) - if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) - if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) - if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) - if (CS%id_TKE_mech_decay > 0) & - call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) - if (CS%id_TKE_conv_decay > 0) & - call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) - if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) - if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) - if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) - if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - ! only write random patterns if running with stochastic physics, otherwise the - ! array is unallocated and will give an error - if (stoch_CS%pert_epbl) then - if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) - if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) - endif + if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) + if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) + if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) + if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) + if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) + if (stoch_CS%pert_epbl) then + if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) + if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif end subroutine energetic_PBL @@ -521,7 +500,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, epbl1_wt, epbl2_wt, i, j) + Waves, G, i, j, epbl1_wt, epbl2_wt) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -558,16 +537,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less - !! than dt if there are two calls to mixedlayer [T ~> s]. - type(wave_parameters_CS), & - optional, pointer :: Waves !< Wave CS for Langmuir turbulence - type(ocean_grid_type), & - optional, intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt ! random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt ! random number to perturb KE dissipation - integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) - integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation + real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation + integer, intent(in) :: i !< The i-index to work on (used for Waves) + integer, intent(in) :: j !< The i-index to work on (used for Waves) ! This subroutine determines the diffusivities in a single column from the integrated energetics ! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes @@ -941,11 +916,10 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) else - mech_TKE = mech_TKE * exp_kh + mech_TKE = mech_TKE * exp_kh endif - !if ( i .eq. 10 .and. j .eq. 10 .and. k .eq. nz) print*,'mech TKE', mech_TKE ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 56401b637942c171968cba3af309fcafa7019c63 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Dec 2021 09:34:18 -0500 Subject: [PATCH 037/155] +Add MOM_check_scaling.F90 and MOM_scaling_check.F90 Added two new modules, the MOM6-specific MOM_check_scaling.F90 and the generic framework module MOM_scaling_check.F90, to assess the uniqueness of the unit scaling factors for all of the variables used by MOM6. If there are overlaps in scaling factors for different units, this also identifies and suggests alternate scaling factors with less overlaps. This commit includes the introduction of the new publicly visible routines check_scaling_factors(), scales_to_powers() and check_MOM6_scaling_factors. This new capability does not do anything for sufficiently low levels of model verbosity, and it is silent if the scaling factors are unique, or if less than 2 dimensions are being rescaled. All answers and output files are bitwise identical, but there can be additional messages to stdout. --- src/core/MOM.F90 | 3 + src/core/MOM_check_scaling.F90 | 221 +++++++++++++++++ src/framework/MOM_scaling_check.F90 | 353 ++++++++++++++++++++++++++++ 3 files changed, 577 insertions(+) create mode 100644 src/core/MOM_check_scaling.F90 create mode 100644 src/framework/MOM_scaling_check.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c36c0545e1..4a82eac903 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -56,6 +56,7 @@ module MOM use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS +use MOM_check_scaling, only : check_MOM6_scaling_factors use MOM_coord_initialization, only : MOM_initialize_coord use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end @@ -2285,6 +2286,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif ! dG_in is retained for now so that it can be used with write_ocean_geometry_file() below. + if (is_root_PE()) call check_MOM6_scaling_factors(CS%GV, US) + call callTree_waypoint("grids initialized (initialize_MOM)") call MOM_timing_init(CS) diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 new file mode 100644 index 0000000000..b707b65bc9 --- /dev/null +++ b/src/core/MOM_check_scaling.F90 @@ -0,0 +1,221 @@ +!> This module is used to check the scaling factors used by the MOM6 ocean model +module MOM_check_scaling + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity +use MOM_scaling_check, only : check_scaling_factors, scales_to_powers +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_MOM6_scaling_factors + +contains + +!> Evaluate whether the dimensional scaling factors provide unique tests for all of the combinations +!! of dimensions that are used in MOM6 (or perhaps widely used), and if they are not unique, explore +!! whether another combination of scaling factors can be found that is unique or has less common +!! cases with coinciding scaling. +subroutine check_MOM6_scaling_factors(GV, US) + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer, parameter :: ndims = 6 ! The number of rescalable dimensional factors. + real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units. + integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. + character(len=2), dimension(ndims) :: key + ! character(len=128) :: mesg, msg_frag + integer, allocatable :: weights(:) + character(len=80), allocatable :: descriptions(:) + ! logical :: verbose, very_verbose + integer :: n, ns, max_pow + + ! Set the names and scaling factors of the dimensions being rescaled. + key(:) = ["Z", "H", "L", "T", "R", "Q"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg /) + call scales_to_powers(scales, scale_pow2) + max_pow = 40 ! 60 + + ! The first call is just to find out how many elements are in the list of scaling combinations. + call compose_dimension_list(ns, descriptions, weights) + + allocate(descriptions(ns)) + do n=1,ns ; descriptions(n) = "" ; enddo + allocate(weights(ns), source=0) + ! This call records all the list of powers, the descriptions, and their weights. + call compose_dimension_list(ns, descriptions, weights) + + call check_scaling_factors("MOM6", descriptions, weights, key, scale_pow2, max_pow) + + deallocate(weights) + deallocate(descriptions) + +end subroutine check_MOM6_scaling_factors + + +!> This routine composes a list of the commonly used dimensional scaling factors in the MOM6 +!! code, along with weights reflecting the frequency of their occurrence in the MOM6 code or +!! other considerations of how likely the variables are be used. +subroutine compose_dimension_list(ns, des, wts) + integer, intent(out) :: ns !< The running sum of valid descriptions + character(len=*), allocatable, intent(inout) :: des(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integer weights for each scaling factor, + !! perhaps the number of times it occurs in the MOM6 code. + + ns = 0 + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 1239) ! Layer thicknesses + call add_scaling(ns, des, wts, "[Z ~> m]", 660) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 506) ! Horizontal velocities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 356) ! Densities + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 247) ! Rates + call add_scaling(ns, des, wts, "[T ~> s]", 237) ! Time intervals + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 231) ! Dynamic pressure + ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 181) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 174) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 163) ! Volume or mass transports + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 136) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[L ~> m]", 107) ! Horizontal distances + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 104) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 89) ! Inverse cell thicknesses + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 88) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 85) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 78) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 69) ! Squared shears and buoyancy frequency + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 68) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 67) ! Horizontal areas + + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 61) ! Specific volumes + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 62) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 60) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 57) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 52) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 51) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 45) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 42) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 33) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 35) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 33) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 32) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[R L Z T-2 ~> Pa]", 27) ! Wind stresses + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 33) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z L2 T-2 ~> J m-2]", 25) ! Integrated energy + ! call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]") ! Depth integral of pressures (25) + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 25) ! Integrated energy + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 24) ! Layer-integrated density + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 20) ! pbce or gtot + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 19) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 18) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 17) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 15) ! Slopes + call add_scaling(ns, des, wts, "[Z L2 ~> m3]", 14) ! Diagnostic volumes + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 12) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 14) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 12) ! Squared vertical distances + call add_scaling(ns, des, wts, "[R Z L2 T-1 ~> kg s-1]", 12) ! Mass fluxes + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 12) ! Inverse areas + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]", 11) ! Gravitational acceleration over density + call add_scaling(ns, des, wts, "[Z T-2 ~> m s-2]", 10) ! Buoyancy differences or their derivatives + ! Could also add [Z T-2 degC-1 ~> m s-2 degC-1] or [Z T-2 ppt-1 ~> m s-2 ppt-1] + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 10) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[L3 ~> m3]", 10) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 9) ! Inverse of denominator in some weighted averages + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 9) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 9) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 9) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 8) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) + call add_scaling(ns, des, wts, "[Q degC-1 ~> J kg-1 degC-1]", 7) ! Heat capacity + + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 6) ! Potential energy height derivatives + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 7) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R L2 T-2 Z-1 ~> Pa m-1]", 7) ! Converts depth to pressure + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 7) ! Rigidity of ice + call add_scaling(ns, des, wts, "[H L2 T-3 ~> m3 s-3]", 9) ! Kinetic energy diagnostics + call add_scaling(ns, des, wts, "[H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]", 6) ! Layer potential vorticity + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 3) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[Z2 L-2 ~> 1]", 1) ! Slopes squared + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 6) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 6) ! Pressure conversion factor + ! Could also add [m T2 R-1 L-2 ~> m Pa-1] + ! Could also add [degC T2 R-1 L-2 ~> degC Pa-1] + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 5) ! Vertical density gradients + call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure + call add_scaling(ns, des, wts, "[L Z-1 ~> nondim]", 4) ! Inverse slopes + call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 20) ! Diagnostic conversions to mass + ! Could also add [m3 H-1 L-2 ~> 1 or m3 kg-1] + call add_scaling(ns, des, wts, "[Z T-2 R-1 ~> m4 s-2 kg-1]", 9) ! Gravitational acceleration over density + call add_scaling(ns, des, wts, "[R Z L4 T-3 ~> kg m2 s-3]", 9) ! MEKE fluxes + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 3) ! Thickness to pressure conversion + + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 3) ! Inverse of column mass + call add_scaling(ns, des, wts, "[L4 ~> m4]", 3) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[T-1 Z-1 ~> s-1 m-1]", 2) ! Barotropic PV, for some options + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 2) ! River mixing term [R Z2 T-1 ~> Pa s] + call add_scaling(ns, des, wts, "[degC Q-1 ~> kg degC J-1]", 2) ! Inverse heat capacity + ! Could add call add_scaling(ns, des, wts, "[Q-1 ~> kg J-1]", 1) ! Inverse heat content + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 2) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R Z-1 ~> kg m-4]", 3) ! Vertical density gradient + call add_scaling(ns, des, wts, "[R Z L2 ~> kg]", 3) ! Depth and time integrated mass fluxes + call add_scaling(ns, des, wts, "[R L2 T-3 ~> W m-2]", 3) ! Depth integrated friction work + call add_scaling(ns, des, wts, "[ppt2 R-2 ~> ppt2 m6 kg-2]", 3) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R L-1 ~> kg m-4]", 2) ! Horizontal density gradient + ! Could add call add_scaling(ns, des, wts, "[H Z ~> m2 or kg m-1]", 2) ! Temporary variables + call add_scaling(ns, des, wts, "[Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]", 2) ! Heating to PE change + call add_scaling(ns, des, wts, "[R2 L2 Z2 T-4 ~> Pa2]", 2) ! Squared wind stresses + call add_scaling(ns, des, wts, "[L-2 T-2 ~> m-2 s-2]", 2) ! Squared Laplacian of velocity + call add_scaling(ns, des, wts, "[T H Z-1 ~> s or s kg m-3]", 2) ! Time step times thickness conversion + call add_scaling(ns, des, wts, "[T H Z-1 R-1 ~> s m3 kg-1 or s]", 2) ! Time step over density with conversion + call add_scaling(ns, des, wts, "[H-3 ~> m-3 or m6 kg-3]", 1) ! A local term in ePBL + call add_scaling(ns, des, wts, "[H-4 ~> m-4 or m8 kg-4]", 1) ! A local term in ePBL + call add_scaling(ns, des, wts, "[H T Z-2 ~> s m-1 or kg s m-4]", 1) ! A local term in ePBL + + call add_scaling(ns, des, wts, "[H3 ~> m3 or kg3 m-6]", 1) ! Thickness cubed in a denominator + call add_scaling(ns, des, wts, "[H2 T-2 ~> m2 s-2 or kg2 m-4 s-2]", 1) ! Thickness times f squared + call add_scaling(ns, des, wts, "[H T2 R-1 Z-2 ~> m Pa-1 or s2 m-1]", 1) ! Pressure to thickness conversion + call add_scaling(ns, des, wts, "[L2 Z-2 ~> nondim]", 1) ! Inverse slope squared + call add_scaling(ns, des, wts, "[H R L2 T-2 ~> m Pa]", 1) ! Integral in thickness of pressure + call add_scaling(ns, des, wts, "[R T2 Z-1 ~> kg s2 m-4]", 1) ! Density divided by gravitational acceleration + +end subroutine compose_dimension_list + +!> Augment the count the valid unit descriptions, and add the provided description and its weight +!! to the end of the list if that list is allocated. +subroutine add_scaling(ns, descs, wts, scaling, weight) + integer, intent(inout) :: ns !< The running sum of valid descriptions. + character(len=*), allocatable, intent(inout) :: descs(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integers for each scaling + character(len=*), intent(in) :: scaling !< The unit description that will be converted + integer, optional, intent(in) :: weight !< An optional weight or occurrence count + !! for this unit description, 1 by default. + + integer :: iend + + iend = index(scaling, "~>") + if (iend <= 1) then + call MOM_mesg("No scaling indicator ~> found for "//trim(scaling)) + else + ! Count and perhaps store this description and its weight. + ns = ns + 1 + if (allocated(descs)) descs(ns) = scaling + if (allocated(wts)) then + wts(ns) = 1 ; if (present(weight)) wts(ns) = weight + endif + endif + +end subroutine add_scaling + +end module MOM_check_scaling diff --git a/src/framework/MOM_scaling_check.F90 b/src/framework/MOM_scaling_check.F90 new file mode 100644 index 0000000000..e32e668b17 --- /dev/null +++ b/src/framework/MOM_scaling_check.F90 @@ -0,0 +1,353 @@ +!> This module is used to check the scaling factors used by the MOM6 ocean model +module MOM_scaling_check + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_scaling_factors, scales_to_powers + +contains + +!> This subroutine does a checks whether the provided dimensional scaling factors give a unique +!! overall scaling for each of the combinations of units in description, and suggests a better +!! combination if it is not unique. However, this subroutine does nothing if the verbosity level +!! for this run is below 3. +subroutine check_scaling_factors(component, descs, weights, key, scales, max_powers) + character(len=*), intent(in) :: component !< The name of the component (e.g., MOM6) to use in messages + character(len=*), intent(in) :: descs(:) !< The descriptions for each combination of units + integer, intent(in) :: weights(:) !< A list of the weights for each described combination + character(len=*), intent(in) :: key(:) !< The key for the unit scaling + integer, intent(in) :: scales(:) !< The powers of 2 that give the scaling for each unit in key + integer, optional, intent(in) :: max_powers !< The maximum range of powers of 2 to search for + !! suggestions of better scaling factors, or 0 to avoid + !! suggesting improved factors. + + ! Local variables + integer, dimension(size(key)) :: next_scales, prev_scales, better_scales + character(len=512) :: mesg + character(len=64) :: msg_frag + integer, dimension(size(key), size(weights)) :: list + integer :: verbosity + logical :: same_key + integer :: orig_cost, test_cost, better_cost, prev_cost ! Various squared-weight mismatch costs. + integer :: better_dp ! The absolute change in powers with the better estimate. + integer :: ndims, ns, m, n, i, p, itt, max_itt, max_pow + + call assert((size(scales) == size(key)), "check_scaling_factors: Mismatched scales and key sizes.") + call assert((size(descs) == size(weights)), "check_scaling_factors: Mismatched descs and weights.") + + verbosity = MOM_get_verbosity() + ! Skip the rest of this routine if it would not write anything out. + if (verbosity < 3) return + + ndims = size(key) + ns = size(weights) + max_pow = 0 ; if (present(max_powers)) max_pow = max_powers + + list(:,:) = 0 + do n=1,ns + call encode_dim_powers(descs(n), key, list(:,n)) + enddo + + if (verbosity >= 7) then + write(mesg, '(I8)') ns + call MOM_mesg(trim(component)//": Extracted "//trim(adjustl(mesg))//" unit combinations from the list.") + mesg = "Dim Key: [" + do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo + mesg = trim(mesg)//"]:" + call MOM_mesg(mesg) + do n=1,ns + call MOM_mesg(trim(component)//": Extracted ["//trim(int_array_msg(list(:,n)))//"] from "//trim(descs(n))) + enddo + + do n=1,ns ; do m=1,n-1 + same_key = .true. + do i=1,ndims ; if (list(i,n) /= list(i,m)) same_key = .false. ; enddo + if (same_key) then + call MOM_mesg(trim(component)//": The same powers occur for "//& + trim(descs(n))//" and "//trim(descs(m))//"." ) + endif + enddo ; enddo + endif + + orig_cost = non_unique_scales(scales, list, descs, weights, silent=(verbosity<4)) + + max_itt = 3*ndims ! Do up to 3 iterations for each rescalable dimension. + if (orig_cost /= 0) then + call MOM_mesg(trim(component)//": The dimensional scaling factors are not unique.") + prev_cost = orig_cost + prev_scales(:) = scales(:) + do itt=1,max_itt + ! Iterate to find a better solution. + better_scales(:) = prev_scales(:) + better_cost = prev_cost + better_dp = 0 + do i=1,ndims + if (scales(i) == 0) cycle ! DO not optimize unscaled dimensions. + next_scales(:) = prev_scales(:) + do p=-max_pow,max_pow + if ((p==0) .or. (p==prev_scales(i))) cycle + next_scales(i) = p + test_cost = non_unique_scales(next_scales, list, descs, weights, silent=.true.) + if ((test_cost < better_cost) .or. & + ((test_cost == better_cost) .and. (abs(p-prev_scales(i)) < better_dp))) then + ! This is a better scaling or has the same weighted mismatches but smaller + ! changes in rescaling factors, so it could be the next guess. + better_scales(:) = next_scales(:) + better_cost = test_cost + better_dp = abs(p - prev_scales(i)) + endif + enddo + enddo + if (better_cost < prev_cost) then + ! Store the new best guess and try again. + prev_scales(:) = better_scales(:) + prev_cost = better_cost + else ! No further optimization is possible. + exit + endif + if (better_cost == 0) exit + if (verbosity >= 7) then + write(mesg, '("Iteration ",I2," scaling cost reduced from ",I8," with original scales to ", I8)') & + itt, orig_cost, better_cost + call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.") + endif + enddo + if (prev_cost < orig_cost) then + test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4)) + mesg = trim(component)//": Suggested improved scales: " + do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then + write(msg_frag, '(I3)') prev_scales(i) + mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(adjustl(msg_frag)) + endif ; enddo + call MOM_mesg(mesg) + + write(mesg, '(I8)') orig_cost + write(msg_frag, '(I8)') test_cost + mesg = trim(component)//": Scaling overlaps reduced from "//trim(adjustl(mesg))//& + " with original scales to "//trim(adjustl(msg_frag))//" with suggested scales." + call MOM_mesg(mesg) + endif + + endif + +end subroutine check_scaling_factors + +!> Convert a unit scaling descriptor into an array of the dimensions of powers given in the key +subroutine encode_dim_powers(scaling, key, dim_powers) + + character(len=*), intent(in) :: scaling !< The unit description that will be converted + character(len=*), dimension(:), intent(in) :: key(:) !< The key for the unit scaling + integer, dimension(size(key)), intent(out) :: dim_powers !< The dimensions in scaling of each + !! element of they key. + + ! Local variables + character(len=:), allocatable :: actstr ! The full active remaining string to be parsed. + character(len=:), allocatable :: fragment ! The space-delimited fragment being parsed. + character(len=:), allocatable :: dimnm ! The probable dimension name + character(len=11) :: numbers ! The list of characters that could make up the exponent. + ! character(len=128) :: mesg + integer :: istart, iend, ieq, ief, ipow ! Positions in strings. + integer :: dp ! The power for this dimension. + integer :: ndim ! The number of dimensional scaling factors to consider. + integer :: n + + dim_powers(:) = 0 + + iend = index(scaling, "~>") - 1 + if (iend < 1) return + + ! Parse the key. + ndim = size(key) + numbers = "-0123456789" + + ! Strip away any leading square brace. + istart = index(scaling(:iend), "[") + 1 + ! If there is an "=" in the string, start after this. + ieq = index(scaling(istart:iend), "=", back=.true.) + if (ieq > 0) istart = istart + ieq + + ! Set up the active string to work on. + actstr = trim(adjustl(scaling(istart:iend))) + do ! Loop over each of the elements in the unit scaling descriptor. + if (len_trim(actstr) == 0) exit + ief = index(actstr, " ") - 1 + if (ief <= 0) ief = len_trim(actstr) + fragment = actstr(:ief) + ipow = scan(fragment, "-") + if (ipow == 0) ipow = scan(fragment, numbers) + + if (ipow == 0) then ! There is no exponent + dimnm = fragment + dp = 1 + ! call MOM_mesg("Parsing powerless fragment "//trim(fragment)//" from "//trim(scaling)) + else + if (verify(fragment(ipow:), numbers) == 0) then + read(fragment(ipow:),*) dp + dimnm = fragment(:ipow-1) + ! write(mesg, '(I3)') dp + ! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//& + ! " as "//trim(dimnm)//trim(adjustl(mesg))) + else + dimnm = fragment + dp = 1 + ! call MOM_mesg("Unparsed fragment "//trim(fragment)//" from "//trim(scaling)) + endif + endif + + do n=1,ndim + if (trim(dimnm) == trim(key(n))) then + dim_powers(n) = dim_powers(n) + dp + exit + endif + enddo + + ! Remove the leading fragment that has been parsed from actstr + actstr = trim(adjustl(actstr(ief+1:))) + enddo + +end subroutine encode_dim_powers + +!> Find the integer power of two that describe each of the scaling factors, or return 0 for +!! scaling factors that are not exceptionally close to an integer power of 2. +subroutine scales_to_powers(scale, pow2) + real, intent(in) :: scale(:) !< The scaling factor for each dimension + integer, intent(out) :: pow2(:) !< The exact powers of 2 for each scale, or 0 for non-exact powers of 2. + + real :: log2_sc ! The log base 2 of an element of scale + integer :: n, ndim + + ndim = size(scale) + + ! Find the integer power of two for the scaling factors, but skip the analysis of any factors + ! that are not close enough to being integer powers of 2. + do n=1,ndim + if (abs(scale(n)) > 0.0) then + log2_sc = log(abs(scale(n))) / log(2.0) + else + log2_sc = 0.0 + endif + if (abs(log2_sc - nint(log2_sc)) < 1.0e-6) then + ! This is close to an integer power of two. + pow2(n) = nint(log2_sc) + else + ! This is not being scaled by an integer power of 2, so return 0. + pow2(n) = 0 + endif + enddo + +end subroutine scales_to_powers + +!> Determine from the list of scaling factors and the unit combinations that are in use whether +!! all these combinations scale uniquely. +integer function non_unique_scales(scales, list, descs, weights, silent) + integer, intent(in) :: scales(:) !< The power of 2 that gives the scaling factor for each dimension + integer, intent(in) :: list(:,:) !< A list of the integers for each scaling + character(len=*), intent(in) :: descs(:) !< The unit descriptions that have been converted + integer, intent(in) :: weights(:) !< A list of the weights for each scaling + logical, optional, intent(in) :: silent !< If present and true, do not write any output. + + ! Local variables + integer, dimension(size(weights)) :: res_pow ! The net rescaling power for each combination. + integer, dimension(size(weights)) :: wt_merge ! The merged weights of scaling factors with common powers + ! for the dimensions being tested. + logical :: same_key, same_scales, verbose + character(len=256) :: mesg + integer :: nonzero_count ! The number of non-zero scaling factors + integer :: ndim ! The number of dimensional scaling factors to work with + integer :: i, n, m, ns + + verbose = .true. ; if (present(silent)) verbose = .not.silent + + ndim = size(scales) + ns = size(descs) + call assert((size(scales) == size(list, 1)), "non_unique_scales: Mismatched scales and list sizes.") + call assert((size(descs) == size(list, 2)), "non_unique_scales: Mismatched descs and list sizes.") + call assert((size(descs) == size(weights)), "non_unique_scales: Mismatched descs and weights.") + + ! Return .true. if all scaling powers are 0, or there is only one scaling factor in use. + nonzero_count = 0 ; do n=1,ndim ; if (scales(n) /= 0) nonzero_count = nonzero_count + 1 ; enddo + if (nonzero_count <= 1) return + + ! Figure out which unit combinations are unique for the set of dimensions and scaling factors + ! that are being tested, and combine the weights for scaling factors. + wt_merge(:) = weights(:) + do n=1,ns ; do m=1,n-1 + same_key = .true. + same_scales = .true. + do i=1,ndim + if (list(i,n) /= list(i,m)) same_key = .false. + if ((scales(i) /= 0) .and. (list(i,n) /= list(i,m))) same_scales = .false. + enddo + if (same_key .or. same_scales) then + if (wt_merge(n) > wt_merge(m)) then + wt_merge(n) = wt_merge(n) + wt_merge(m) + wt_merge(m) = 0 + else + wt_merge(m) = wt_merge(m) + wt_merge(n) + wt_merge(n) = 0 + endif + endif + if (wt_merge(n) == 0) exit ! Go to the next value of n. + enddo ; enddo + + do n=1,ns + res_pow(n) = 0 + do i=1,ndim + res_pow(n) = res_pow(n) + scales(i) * list(i,n) + enddo + enddo + + ! Determine the weighted cost of non-unique scaling factors. + non_unique_scales = 0 + do n=1,ns ; if (wt_merge(n) > 0) then ; do m=1,n-1 ; if (wt_merge(m) > 0) then + if (res_pow(n) == res_pow(m)) then + ! Use the product of the weights as the cost, as this should be vaguely proportional to + ! the likelihood that these factors would be combined in an expression. + non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999) + if (verbose) then + write(mesg, '(I8)') res_pow(n) + call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//& + trim(adjustl(mesg))//" for the given powers.") + + ! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//& + ! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//& + ! trim(int_array_msg(scales))//"]") + endif + endif + endif ; enddo ; endif ; enddo + +end function non_unique_scales + +!> Return a string the elements of an array of integers +function int_array_msg(array) + integer, intent(in) :: array(:) !< The array whose values are to be written. + character(len=16*size(array)) :: int_array_msg + + character(len=12) :: msg_frag + integer :: i, ni + ni = size(array) + + int_array_msg = "" + if (ni < 1) return + + do i=1,ni + write(msg_frag, '(I8)') array(i) + msg_frag = adjustl(msg_frag) + if (i == 1) then + int_array_msg = trim(msg_frag) + else + int_array_msg = trim(int_array_msg)//" "//trim(msg_frag) + endif + enddo +end function int_array_msg + +end module MOM_scaling_check From 75bf521e29e3434965b44cea288404bb0be341af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Jan 2022 17:04:25 -0500 Subject: [PATCH 038/155] +Move MOM_scaling_check.F90 to MOM_unique_scales.F90 Renamed the framework module MOM_scaling_check.F90 to MOM_unique_scales.F90 to help differentiate it from MOM_check_scaling.F90, and renamed the subroutine check_scaling_factors() as check_scaling_uniqueness(). Also added _Dimensional_consistency.dox to describe the dimensional consistency testing. This commit should address the issues raised in the review of MOM6 PR #49. All answers and output are bitwise identical. --- src/core/MOM_check_scaling.F90 | 6 +- ...caling_check.F90 => MOM_unique_scales.F90} | 13 +-- src/framework/_Dimensional_consistency.dox | 85 +++++++++++++++++++ 3 files changed, 95 insertions(+), 9 deletions(-) rename src/framework/{MOM_scaling_check.F90 => MOM_unique_scales.F90} (97%) create mode 100644 src/framework/_Dimensional_consistency.dox diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 index b707b65bc9..55bd471fee 100644 --- a/src/core/MOM_check_scaling.F90 +++ b/src/core/MOM_check_scaling.F90 @@ -1,10 +1,10 @@ -!> This module is used to check the scaling factors used by the MOM6 ocean model +!> This module is used to check the dimensional scaling factors used by the MOM6 ocean model module MOM_check_scaling ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity -use MOM_scaling_check, only : check_scaling_factors, scales_to_powers +use MOM_unique_scales, only : check_scaling_uniqueness, scales_to_powers use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -53,7 +53,7 @@ subroutine check_MOM6_scaling_factors(GV, US) ! This call records all the list of powers, the descriptions, and their weights. call compose_dimension_list(ns, descriptions, weights) - call check_scaling_factors("MOM6", descriptions, weights, key, scale_pow2, max_pow) + call check_scaling_uniqueness("MOM6", descriptions, weights, key, scale_pow2, max_pow) deallocate(weights) deallocate(descriptions) diff --git a/src/framework/MOM_scaling_check.F90 b/src/framework/MOM_unique_scales.F90 similarity index 97% rename from src/framework/MOM_scaling_check.F90 rename to src/framework/MOM_unique_scales.F90 index e32e668b17..730d11adb0 100644 --- a/src/framework/MOM_scaling_check.F90 +++ b/src/framework/MOM_unique_scales.F90 @@ -1,5 +1,6 @@ -!> This module is used to check the scaling factors used by the MOM6 ocean model -module MOM_scaling_check +!> This module provides tools that can be used to check the uniqueness of the dimensional +!! scaling factors used by the MOM6 ocean model or other models +module MOM_unique_scales ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,7 +13,7 @@ module MOM_scaling_check ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units ! vary with the Boussinesq approximation, the Boussinesq variant is given first. -public check_scaling_factors, scales_to_powers +public check_scaling_uniqueness, scales_to_powers contains @@ -20,7 +21,7 @@ module MOM_scaling_check !! overall scaling for each of the combinations of units in description, and suggests a better !! combination if it is not unique. However, this subroutine does nothing if the verbosity level !! for this run is below 3. -subroutine check_scaling_factors(component, descs, weights, key, scales, max_powers) +subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_powers) character(len=*), intent(in) :: component !< The name of the component (e.g., MOM6) to use in messages character(len=*), intent(in) :: descs(:) !< The descriptions for each combination of units integer, intent(in) :: weights(:) !< A list of the weights for each described combination @@ -139,7 +140,7 @@ subroutine check_scaling_factors(component, descs, weights, key, scales, max_pow endif -end subroutine check_scaling_factors +end subroutine check_scaling_uniqueness !> Convert a unit scaling descriptor into an array of the dimensions of powers given in the key subroutine encode_dim_powers(scaling, key, dim_powers) @@ -350,4 +351,4 @@ function int_array_msg(array) enddo end function int_array_msg -end module MOM_scaling_check +end module MOM_unique_scales diff --git a/src/framework/_Dimensional_consistency.dox b/src/framework/_Dimensional_consistency.dox new file mode 100644 index 0000000000..0657724381 --- /dev/null +++ b/src/framework/_Dimensional_consistency.dox @@ -0,0 +1,85 @@ +/*! \page Dimensional_consistency Dimensional Consistency Testing + +\section section_Dimensional_consistency Dimensional Consistency Testing + + MOM6 uses a unique system for testing the dimensional consistency of all of +its expressions. The internal representations of dimensional variables are +rescaled by integer powers of 2 that depend on their units, with all input and +output being rescaled back to their original MKS units. By choosing different +powers of 2 for different units, the internal representations with different +units scale differently, so dimensionally inconsistent expressions will not +reproduce, but dimensionally inconsistent expressions give bitwise identical +results. So, for example, if horizontal lengths scale by a factor of 2^6=64, +and time is scaled by a factor of 2^4=16, horizontal velocities will scale by a +factor of 2^(6-4)=4. In this case, expressions that combine velocities, all +terms would scale by the same factor of 4. By contrast, if there were an +expression where a variable with units of length were added to one with the +units of a velocity, the results would scale inconsistently, and answers would +change with different scaling factors. + + What makes these integer powers of 2 special is the way that floating point +numbers are written as an O(1) mantissa times 2 raised to an integer exponent +between +/-1024. Multiplication by an integer power of 2 is just an integer +shift in the exponent, so as long as the model is not rescaled by an overly +large factor to encounter overflows and the model is not relying on automatic +underflows being converted to 0, all floating point operations can be carried +with one scale, and then rescaled to obtain identical answers. MOM6 has the +option to explicitly handle all relevant cases of underflows, and it can be +demonstrated to give identical answers when each of its units are scaled by +factors ranging from 2^-140 ~= 7.2e-43 to 2^140 ~= 1.4e42. + + When running with rescaling factors other than 2^0 = 1, there are some extra +array copies and multiplies of input fields or diagnostic output, so it is +slightly more efficient not to actively use the dimensional rescaling. For +production runs, we typically set all of the rescaling powers to 0, but for +debugging code problems, this rescaling can be an invaluable tool, especially +when combined with the very verbose runtime setting DEBUG=True in a MOM_input or +MOM_override file. Diffs of the output from runs with different scaling factors +readily highlights the earliest instances of differences, which can be used to +track down any dimensionally inconsistent expressions. Similarly, dimensional +inconsistencies in diagnostics is easily tracked down by comparing the output +from a pair of runs. + + All real variables in MOM6 should have comments describing their purpose, +along with their rescaled units and their mks counterparts with notation like +"! A velocity [L T-1 ~> m s-1]". If the units vary with the Boussinesq +approximation, the Boussinesq variant is given first. When variables are read +in, their dimensions are usually specified with a 'scale=' optional argument on +the MOM_get_param or MOM_read_data call, while the unscaling of diagnostics is +specified with a 'conversion=' factor. In both cases, these arguments it next +to a text string specifying the variable's units, which can then be check easily +for self-consistency. + + Currently in MOM6, the following dimensions have unique scaling, along with +the notation used to describe these variables in comments: + +\li Time, scaled by 2^T_RESCALE_POWER, denoted as [T ~> s] +\li Horizontal length, scaled by 2^L_RESCALE_POWER, denoted as [L ~> m] +\li Vertical height, scaled by 2^Z_RESCALE_POWER, denoted as [Z ~> m] +\li Vertical thickness, scaled by 2^H_RESCALE_POWER, denoted as [H ~> m or kg m-2] +\li Density, scaled by 2^R_RESCALE_POWER, denoted as [R ~> kg m-3] +\li Enthalpy (or heat content), scaled by 2^Q_RESCALE_POWER, denoted as [Q ~> J kg-1] + + These rescaling capabilities are also used by the SIS2 sea ice model, but it +does uses a non-Boussinesq mass scale of [R Z ~> kg m-2] for ice thicknesses, +rather than having a separate scaling factor (of [H ~> m or kg m-2]) that varies +between the Boussinesq and non-Boussinesq modes like MOM6 does. The actual +powers used in the scaling are specified separately for MOM6 and SIS2 and +need not be the same. + + Each of these units can be scaled in separate test runs, or all of them can be +rescaled simultaneously. In the latter case, MOM_unique_scales.F90 provides +tools to evaluate whether the specific combinations of units used by a model +scale by unique powers, and it can suggest scaling factors that provides unique +combinations of rescaling factors for the dimensions being tested, using a +cost-function based on the frequency with which units are used in the model (and +specified inside of MOM_check_scaling.F90), with a cost going as the product of +the frequency of units that resolve to the same scaling factor. + + A separate set of scaling factors could also be used for different chemical +tracer concentrations, for example. In this case, the tools in +MOM_unique_scales.F90 could still be used, but there would need to be a separate +equivalent of the unit_scaling_type with variables that are appropriate to the +units of the tracers. + +*/ From fc5253f73c34b2fafff0fe446d6e4cd75e317752 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Jan 2022 14:07:37 -0500 Subject: [PATCH 039/155] (*)Correct memory declarations in MOM_regridding Corrected memory declarations in MOM_regridding.F90 in cases where the vertical size of the input and output grids are not the same. Although this is not know to have caused any particular problems, these inconsistencies could lead to segmentation faults in cases where the target grid (e.g., diagnostic output) is larger than the input grid (e.g., the model's native grid). In some cases, certain grid generation options were only written to work with the same size of input and output grids, and error handling has been added to these cases to gracefully bring down the model if they are used with different grid sizes. All answers are bitwise identical in the MOM6-examples test suite, but it is conceivable that this could correct subtle (memory-related) issues in some configurations. --- src/ALE/MOM_regridding.F90 | 108 +++++++++++++++++++++++-------------- 1 file changed, 67 insertions(+), 41 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 94d7852851..dafd165245 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -3,7 +3,7 @@ module MOM_regridding ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data use MOM_io, only : verify_variable_units, slasher @@ -776,11 +776,11 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after !! the last time step type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) - real, dimension(SZI_(G),SZJ_(G), CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment ! Local variables @@ -827,7 +827,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end select ! type of grid #ifdef __DO_SAFETY_CHECKS__ - call check_remapping_grid(G, GV, h, dzInterface,'in regridding_main') + if (CS%nk == GV%ke) call check_remapping_grid(G, GV, h, dzInterface,'in regridding_main') #endif end subroutine regridding_main @@ -1086,13 +1086,14 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. ! Local variables real :: nominalDepth, minThickness, totalThickness, dh ! Depths and thicknesses [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Coordinate interface heights [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] integer :: i, j, k, nz logical :: ice_shelf @@ -1144,17 +1145,23 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness - write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz - do k=1,nz+1 + write(0,*) 'dzInterface(1) = ', dzInterface(i,j,1), epsilon(dh), nz, CS%nk + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,nz + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),CS%coordinateResolution(k) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_zstar_grid(): top surface has moved!!!' ) endif @@ -1183,14 +1190,15 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] ! Local variables integer :: i, j, k integer :: nz real :: nominalDepth, totalThickness, dh - real, dimension(SZK_(GV)+1) :: zOld, zNew + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] nz = GV%ke @@ -1227,12 +1235,18 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,CS%nk + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_sigma_grid: top surface has moved!!!' ) endif @@ -1266,22 +1280,23 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel !------------------------------------------------------------------------------ ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice !! shelf coverage [nondim] ! Local variables - integer :: nz + integer :: nz ! The number of layers in the input grid integer :: i, j, k real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Old and new interface heights [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ @@ -1355,7 +1370,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - do k = 2,nz + do k=2,CS%nk if (zNew(k) > zOld(1)) then write(0,*) 'zOld=',zOld write(0,*) 'zNew=',zNew @@ -1380,12 +1395,18 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo do k=1,nz write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_rho_grid: top surface has moved!!!' ) endif @@ -1416,10 +1437,10 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she !! coverage [nondim] ! Local variables - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] integer :: i, j, k, nki real :: depth, nominalDepth real :: h_neglect, h_neglect_edge @@ -1496,10 +1517,10 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure ! local variables integer :: i, j, k, nz ! indices and dimension lengths @@ -1512,6 +1533,9 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) nz = GV%ke + call assert((GV%ke == CS%nk), "build_grid_adaptive is only written to work "//& + "with the same number of input and target layers.") + ! position surface at z = 0. zInt(:,:,1) = 0. @@ -1562,13 +1586,13 @@ subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position - real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] ! Local variables real :: depth ! Depth of the ocean relative to the mean sea surface height in thickness units [H ~> m or kg m-2] @@ -1585,8 +1609,10 @@ subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) nz = GV%ke - if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_SLight : "//& - "Target densities must be set before build_grid_SLight is called.") + call assert((GV%ke == CS%nk), "build_grid_SLight is only written to work "//& + "with the same number of input and target layers.") + call assert(CS%target_density_set, "build_grid_SLight : "//& + "Target densities must be set before build_grid_SLight is called.") ! Build grid based on target interface densities do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 @@ -1691,13 +1717,13 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) !------------------------------------------------------------------------------ ! Arguments - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(in) :: h !< Original layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface - !! depth [H ~> m or kg m-2] - real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] - type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Original layer thicknesses [H ~> m or kg m-2] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface + !! depth [H ~> m or kg m-2] + real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] ! Local variables integer :: i, j, k From c166358b21a5edb970571b31202c7185990913ea Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 1 Feb 2022 09:58:15 -0500 Subject: [PATCH 040/155] Add optional argument to FMS2 version of get_field_size - default behavior returns field size using fms1 format. --- config_src/infra/FMS2/MOM_io_infra.F90 | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 62a43ab99b..f8999fa7b8 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -598,7 +598,7 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) end function field_exists !> 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) +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain, fms1_format) 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 @@ -607,16 +607,21 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) !! 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 - + logical, optional, intent(in) :: fms1_format !< If true (default) , then for (Nx,Ny,Nt) data + !! return sizes=(Nx,Ny,1,Nt) if sizes if 4-dimensional ! Local variables type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information ! about the exiting time axis entries in append mode. logical :: success ! If true, the file was opened successfully logical :: field_exists ! True if filename exists and field_name is in filename + logical :: fms1_fmt integer :: i, ndims + if (FMS2_reads) then field_exists = .false. + fms1_fmt=.true. + if (present(fms1_format)) fms1_fmt=fms1_format if (file_exists(filename)) then success = fms2_open_file(fileObj_read, trim(filename), "read") if (success) then @@ -627,6 +632,12 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + ! This preserves previous behavior when reading time-varying data without + ! a vertical extent. + if (fms1_fmt .and. size(sizes)==ndims+1) then + sizes(ndims+1)=sizes(ndims) + sizes(ndims)=1 + endif endif endif endif From e8416091589b98ae790c9c3a63e5c7980cc56c73 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 2 Feb 2022 17:10:12 -0500 Subject: [PATCH 041/155] remove unnecessary optional flag --- config_src/infra/FMS2/MOM_io_infra.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index f8999fa7b8..16b7e45bc6 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -598,7 +598,7 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) end function field_exists !> 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, fms1_format) +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 @@ -607,21 +607,16 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain, fm !! 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 - logical, optional, intent(in) :: fms1_format !< If true (default) , then for (Nx,Ny,Nt) data - !! return sizes=(Nx,Ny,1,Nt) if sizes if 4-dimensional ! Local variables type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information ! about the exiting time axis entries in append mode. logical :: success ! If true, the file was opened successfully logical :: field_exists ! True if filename exists and field_name is in filename - logical :: fms1_fmt integer :: i, ndims if (FMS2_reads) then field_exists = .false. - fms1_fmt=.true. - if (present(fms1_format)) fms1_fmt=fms1_format if (file_exists(filename)) then success = fms2_open_file(fileObj_read, trim(filename), "read") if (success) then @@ -634,7 +629,7 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain, fm do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo ! This preserves previous behavior when reading time-varying data without ! a vertical extent. - if (fms1_fmt .and. size(sizes)==ndims+1) then + if (size(sizes)==ndims+1) then sizes(ndims+1)=sizes(ndims) sizes(ndims)=1 endif From 32e1ecf45f8d5064b3f7e986b1e9af226958a919 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Sun, 20 Feb 2022 08:21:17 -0700 Subject: [PATCH 042/155] Fixes issues with the GME code and get_param calls for Leith options (#65) * Eliminate GET_ALL_PARAMS in hor_visc_init Added do_not_log arguments to get_param calls in MOM_hor_visc.F90 that are only used conditionally, and eliminated the unlogged GET_ALL_PARAMS runtime parameter and get_all variable in hor_visc_init(). By design, all logging of parameters after this commit is identical to before, even for variables that are inactive and therefore should not be logged. In several places, there were some problems, mostly with the GME code, that have been noted in comments marked with '###'. Also cleaned up the code alignment and eliminated unneeded temporary variables in a few places in hor_visc(). All solutions are bitwise identical, and no output is changed. * Move call to get get_KH outside k-loop The call to get the 3-d GME diffusivity arrays and the subsequent blocking halo update was moved outside of the k-loop. * Increase loop range for calculation of GME fluxes * Makes GME filter rotationally invariant * Makes the GME filter rotationally invariant * Adds a runtime param to allow the user to control how many smoothing passes should be done. * Rearranges the get_param calls related to Leith The get_param calls for Leith were not in the correct location. This commit fixes that. * Adding halo updates * Fixes do loops indices and adds diagnostics * Adds option to save barotropic tension and strain; * Fixes many i and j loops indices associated with GME to avoid halo problems and unnecessary halo updates. With these changes, the model is now conserving mass and tracers when USE_GME = True. * Fixes issues related to the merging with dev/gfdl * Fixes calculation of FrictWork_GME The calculation now mimics the calculation of FrictWork and it includes the energy diffusion term. * Removes dependency of FrictWork_GME calculation on MEKE * Adding sh_xy_sq and sh_xx_sq in the OMP directives Co-authored-by: Robert Hallberg --- .../lateral/MOM_hor_visc.F90 | 254 ++++++++++-------- 1 file changed, 145 insertions(+), 109 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0249f79c2d..78f48975e5 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2,14 +2,14 @@ module MOM_hor_visc ! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_checksums, only : hchksum, Bchksum +use MOM_checksums, only : hchksum, Bchksum, uvchksum use MOM_coms, only : min_across_PEs use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE +use MOM_domains, only : To_All, Scalar_Pair use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -185,6 +185,7 @@ module MOM_hor_visc ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. + integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes. !>@{ !! Diagnostic id integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 @@ -197,6 +198,8 @@ module MOM_hor_visc integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 + integer :: id_dudx_bt = -1, id_dvdy_bt = -1 + integer :: id_dudy_bt = -1, id_dvdx_bt = -1 integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 @@ -452,12 +455,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (CS%bound_Kh .and. .not.CS%better_bound_Kh) if (CS%use_GME) then + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 boundary_mask_h(i,j) = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) enddo ; enddo - 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)) + do J=Jsq-2,Jeq+1 ; do I=Isq-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 ! initialize diag. array with zeros @@ -468,81 +472,92 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Get barotropic velocities and their gradients call barotropic_get_tav(BT, ubtav, vbtav, G, US) + call pass_vector(ubtav, vbtav, G%Domain) - do j=js-1,je+2 ; do i=is-1,ie+2 + ! Calculate the barotropic horizontal tension + do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & G%IdyCu(I-1,j) * ubtav(I-1,j)) dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & G%IdxCv(i,J-1) * vbtav(i,J-1)) - 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) enddo ; enddo ! Components for the barotropic shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 dvdx_bt(I,J) = CS%DY_dxBu(I,J)*(vbtav(i+1,J)*G%IdyCv(i+1,J) & - vbtav(i,J)*G%IdyCv(i,J)) dudy_bt(I,J) = CS%DX_dyBu(I,J)*(ubtav(I,j+1)*G%IdxCu(I,j+1) & - ubtav(I,j)*G%IdxCu(I,j)) enddo ; enddo - call pass_vector(dudx_bt, dvdy_bt, G%Domain, stagger=BGRID_NE) - call pass_vector(dvdx_bt, dudy_bt, G%Domain, stagger=AGRID) + ! post barotropic tension and strain + if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) + if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) + if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) + if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) if (CS%no_slip) then - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo else - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo endif do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - grad_vel_mag_bt_h(i,j) = boundary_mask_h(i,j) * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & + grad_vel_mag_bt_h(i,j) = G%mask2dT(I,J) * boundary_mask_h(i,j) * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1))+(dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1))+(dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) enddo ; enddo - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - grad_vel_mag_bt_q(I,J) = boundary_mask_q(I,J) * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & + do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 + grad_vel_mag_bt_q(I,J) = G%mask2dBu(I,J) * boundary_mask_q(I,J) * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1))+(dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1))+(dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) enddo ; enddo - do j=js-1,je+1 ; do i=is-1,ie+1 + call pass_var(h, G%domain, halo=2) + + do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = 0.0 enddo ; enddo - do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = htot(i,j) + GV%H_to_Z*h(i,j,k) enddo ; enddo ; enddo I_GME_h0 = 1.0 / CS%GME_h0 - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 if (grad_vel_mag_bt_h(i,j)>0) then - GME_effic_h(i,j) = CS%GME_efficiency * boundary_mask_h(i,j) * & + GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * & (MIN(htot(i,j) * I_GME_h0, 1.0)**2) else GME_effic_h(i,j) = 0.0 endif enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 if (grad_vel_mag_bt_q(I,J)>0) then h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) I_hq = 1.0 / h_arith_q h_harm_q = 0.25 * h_arith_q * ((htot(i,j)*I_hq + htot(i+1,j+1)*I_hq) + & (htot(i+1,j)*I_hq + htot(i,j+1)*I_hq)) - GME_effic_q(I,J) = CS%GME_efficiency * boundary_mask_q(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) + GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) else GME_effic_q(I,J) = 0.0 endif enddo ; enddo + 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, To_All+Scalar_Pair) + + if (CS%debug) & + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, scale=US%L_to_m**2*US%s_to_T) + endif ! use_GME !$OMP parallel do default(none) & @@ -555,7 +570,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -565,10 +580,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$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, 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_h, grad_vel_mag_q, sh_xx_sq, sh_xy_sq, & !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$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 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 & @@ -1426,52 +1441,40 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%use_GME) then - !### This call to get the 3-d GME diffusivity arrays and the subsequent blocking halo update - ! should occur outside of the k-loop, and perhaps the halo update should occur outside of - ! this routine altogether! - 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 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 GME_coeff = GME_effic_h(i,j) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if ((CS%id_GME_coeff_h>0) .or. find_FrictWork) GME_coeff_h(i,j,k) = GME_coeff str_xx_GME(i,j) = GME_coeff * sh_xx_bt(i,j) - enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 GME_coeff = GME_effic_q(I,J) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if (CS%id_GME_coeff_q>0) GME_coeff_q(I,J,k) = GME_coeff str_xy_GME(I,J) = GME_coeff * sh_xy_bt(I,J) - enddo ; enddo ! Applying GME diagonal term. This is linear and the arguments can be rescaled. - call smooth_GME(G, GME_flux_h=str_xx_GME) - call smooth_GME(G, GME_flux_q=str_xy_GME) + call smooth_GME(CS, G, GME_flux_h=str_xx_GME) + call smooth_GME(CS, G, GME_flux_q=str_xy_GME) do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - ! GME is applied below - if (CS%no_slip) then + ! GME is applied below + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * CS%reduction_xy(I,J)) - else + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) - endif - enddo ; enddo - - if (allocated(MEKE%GME_snk)) then - do j=js,je ; do i=is,ie - FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 * grad_vel_mag_bt_h(i,j) enddo ; enddo endif @@ -1555,6 +1558,27 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) enddo ; enddo ; endif + if (CS%use_GME) then + do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + -str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + +0.25*((str_xy_GME(I,J)*( & + (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & + +str_xy_GME(I-1,J-1)*( & + (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & + +(str_xy_GME(I-1,J)*( & + (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & + +str_xy_GME(I,J-1)*( & + (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + enddo ; enddo ; endif + ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any ! energy loss seen as a reduction in the (biharmonic) frictional source term. @@ -1818,11 +1842,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a Leith nonlinear eddy viscosity.", & default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%Leith_Kh = .false. - ! This call duplicates one that occurs 26 lines later, and is probably unneccessary. - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.CS%Laplacian) !### (.not.CS%Leith_Kh)? + call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & + "The nondimensional Laplacian Leith constant, "//& + "often set to 1.0", units="nondim", default=0.0, & + fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & default=.false., do_not_log=.true.) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & @@ -1831,27 +1854,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) do_not_log=.not.(CS%Laplacian.and.use_MEKE)) if (.not.(CS%Laplacian.and.use_MEKE)) CS%res_scale_MEKE = .false. - call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & - "The nondimensional Laplacian Leith constant, "//& - "often set to 1.0", units="nondim", default=0.0, & - fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) - call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & - "If true, use QG Leith nonlinear eddy viscosity.", & - default=.false., do_not_log=.not.CS%Leith_Kh) - if (CS%use_QG_Leith_visc .and. .not. CS%Leith_Kh) call MOM_error(FATAL, & - "MOM_hor_visc.F90, hor_visc_init:"//& - "LEITH_KH must be True when USE_QG_LEITH_VISC=True.") - - !### The following two get_param_calls need to occur after Leith_Ah is read, but for now it replicates prior code. - CS%Leith_Ah = .false. - call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & - "If true, include the beta term in the Leith nonlinear eddy viscosity.", & - default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & "If true, the Laplacian coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%Laplacian) @@ -1944,6 +1946,21 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing=CS%Smagorinsky_Ah, do_not_log=.not.CS%Smagorinsky_Ah) + call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & + "If true, include the beta term in the Leith nonlinear eddy viscosity.", & + default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & + "If true, add a term to Leith viscosity which is "//& + "proportional to the gradient of divergence.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & + "If true, use QG Leith nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") + endif + call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1999,17 +2016,22 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "Use the split time stepping if true.", default=.true., do_not_log=.true.) if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & - "The strength of GME tapers quadratically to zero when the bathymetric "//& - "depth is shallower than GME_H0.", & - units="m", scale=US%m_to_Z, default=1000.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & - "The nondimensional prefactor multiplying the GME coefficient.", & - units="nondim", default=1.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & - "The absolute maximum value the GME coefficient is allowed to take.", & - units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7, & - do_not_log=.not.CS%use_GME) + + if (CS%use_GME) then + call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, & + "Number of smoothing passes for the GME fluxes.", & + units="nondim", default=1) + call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & + "The strength of GME tapers quadratically to zero when the bathymetric "//& + "depth is shallower than GME_H0.", & + units="m", scale=US%m_to_Z, default=1000.0) + call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & + "The nondimensional prefactor multiplying the GME coefficient.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & + "The absolute maximum value the GME coefficient is allowed to take.", & + units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) + endif if (CS%Laplacian .or. CS%biharmonic) then call get_param(param_file, mdl, "DT", dt, & @@ -2492,6 +2514,18 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt endif if (CS%use_GME) then + CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & + 'Zonal component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & + 'Zonal component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & + 'Meridional component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & + 'Meridional component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & @@ -2501,7 +2535,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& - 'Integral work done by lateral friction terms', & + 'Integral work done by lateral friction terms. If GME is turned on, this '//& + 'includes the GME contribution.', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & @@ -2531,7 +2566,8 @@ end subroutine align_aniso_tensor_to_grid !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise -subroutine smooth_GME(G, GME_flux_h, GME_flux_q) +subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) + type(hor_visc_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: GME_flux_h!< GME diffusive flux !! at h points @@ -2542,15 +2578,18 @@ subroutine smooth_GME(G, GME_flux_h, GME_flux_q) real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing integer :: i, j, k, s - do s=1,1 - ! Update halos + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + do s=1,CS%num_smooth_gme if (present(GME_flux_h)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_h, G%Domain) + ! Update halos if needed + if (s >= 2) call pass_var(GME_flux_h, G%Domain) GME_flux_h_original(:,:) = GME_flux_h(:,:) ! apply smoothing on GME - do j = G%jsc, G%jec - do i = G%isc, G%iec + do j = Jsq, Jeq+1 + do i = Isq, Ieq+1 ! skip land points if (G%mask2dT(i,j)==0.) cycle ! compute weights @@ -2558,24 +2597,22 @@ subroutine smooth_GME(G, GME_flux_h, GME_flux_q) we = 0.125 * G%mask2dT(i+1,j) ws = 0.125 * G%mask2dT(i,j-1) wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. + wc = 1.0 - ((ww+we)+(wn+ws)) GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & - + ww * GME_flux_h_original(i-1,j) & - + we * GME_flux_h_original(i+1,j) & - + ws * GME_flux_h_original(i,j-1) & - + wn * GME_flux_h_original(i,j+1) + + ((ww * GME_flux_h_original(i-1,j) & + + 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 endif - ! Update halos if (present(GME_flux_q)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) + ! Update halos if needed + if (s >= 2) call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) GME_flux_q_original(:,:) = GME_flux_q(:,:) ! apply smoothing on GME - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB + do J = Jsq-1, Jeq + do I = Isq-1, Ieq ! skip land points if (G%mask2dBu(I,J)==0.) cycle ! compute weights @@ -2583,13 +2620,12 @@ subroutine smooth_GME(G, GME_flux_h, GME_flux_q) we = 0.125 * G%mask2dBu(I+1,J) ws = 0.125 * G%mask2dBu(I,J-1) wn = 0.125 * G%mask2dBu(I,J+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. + wc = 1.0 - ((ww+we)+(wn+ws)) GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & - + ww * GME_flux_q_original(I-1,J) & - + we * GME_flux_q_original(I+1,J) & - + ws * GME_flux_q_original(I,J-1) & - + wn * GME_flux_q_original(I,J+1) + + ((ww * GME_flux_q_original(I-1,J) & + + 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 endif From 149073fea0b9fa3b82880b59818710d9abbebbd5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Sun, 20 Feb 2022 11:50:18 -0700 Subject: [PATCH 043/155] Remove hard-wired parameter in adjustEtaToFitBathymetry (#69) Subroutine adjustEtaToFitBathymetry had a hard-wired parameter (hTolerance = 0.1) controlling the tolerance when adjusting the thickness to fit the bathymetry. This patch adds an user-controlled parameter (THICKNESS_TOLERANCE), which replaces hTolerance. THICKNESS_TOLERANCE is only activated when ADJUST_THICKNESS=True. --- .../MOM_state_initialization.F90 | 32 +++++++++++++------ 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 22892817e6..8378644ea9 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -688,6 +688,8 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. integer :: inconsistent = 0 logical :: correct_thickness + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path integer :: i, j, k, is, ie, js, je, nz @@ -718,12 +720,18 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(param_file, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, "eta", eta(:,:,:), G%Domain, scale=US%m_to_Z) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, eta, h, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then @@ -757,31 +765,29 @@ end subroutine initialize_thickness_from_file !! layers are contracted to ANGSTROM thickness (which may be 0). !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. -!! @remark{There is a (hard-wired) "tolerance" parameter such that the -!! criteria for adjustment must equal or exceed 10cm.} -subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) +subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) 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] + real, intent(in) :: ht !< Tolerance to exceed adjustment + !! criteria [Z ~> m] real, optional, intent(in) :: dZ_ref_eta !< The difference between the !! reference heights for bathyT and !! eta [Z ~> m], 0 by default. ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] real :: dilate ! A factor by which the column is dilated [nondim] real :: dZ_ref ! The difference in the reference heights for G%bathyT and eta [Z ~> m] character(len=100) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - hTolerance = 0.1*US%m_to_Z dZ_ref = 0.0 ; if (present(dZ_ref_eta)) dZ_ref = dZ_ref_eta contractions = 0 do j=js,je ; do i=is,ie - if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + hTolerance) then + if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + ht) then eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) contractions = contractions + 1 endif @@ -811,7 +817,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. ! This should be... if ((G%mask2dt(i,j)*(eta(i,j,1)-eta(i,j,nz+1)) > 0.0) .and. & - if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - hTolerance) then + if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - ht) then dilations = dilations + 1 if (eta(i,j,1) <= eta(i,j,nz+1)) then do k=1,nz ; h(i,j,k) = (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) / real(nz) ; enddo @@ -2402,6 +2408,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real :: dilate ! A dilation factor to match topography [nondim] real :: missing_value_temp, missing_value_salt logical :: correct_thickness + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: potemp_var, salin_var character(len=8) :: laynum @@ -2535,6 +2543,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & "If true, all the interior layers are adjusted to "//& @@ -2732,7 +2746,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just Hmix_depth, eps_z, eps_rho, density_extrap_bug) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, zi, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, zi, h, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then From d46dbc775949f1e20572e6732fd5d15d19cadbb8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Dec 2021 07:57:23 -0500 Subject: [PATCH 044/155] Report mean temperature from MOM_state_stats() Actually calculate the mean temperature and salinity reported by MOM_state_stats(). Due to an oversight, these means were always being reported as 0. This changes the output when the debugging flag DEBUG_CONSERVATION=True. All answers are bitwise identical. --- src/core/MOM_checksum_packages.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 917a4afdc3..3951dfdc7d 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -253,8 +253,8 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) - tmp_T, & ! The column-integrated temperature [degC m3] - tmp_S ! The column-integrated salinity [ppt m3] + tmp_T, & ! The column-integrated temperature [degC m3] (unscaled to permit reproducing sum) + tmp_S ! The column-integrated salinity [ppt m3] (unscaled to permit reproducing sum) real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] @@ -294,6 +294,8 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe T%average = T%average + dV*Temp(i,j,k) S%minimum = min( S%minimum, Salt(i,j,k) ) ; S%maximum = max( S%maximum, Salt(i,j,k) ) S%average = S%average + dV*Salt(i,j,k) + tmp_T(i,j) = tmp_T(i,j) + dV*Temp(i,j,k) + tmp_S(i,j) = tmp_S(i,j) + dV*Salt(i,j,k) endif if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif From 9c7bf292d975c44c79a68b961509ee51eb788187 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Dec 2021 07:58:01 -0500 Subject: [PATCH 045/155] +Add global_mass_int_EFP Added the new function global_mass_int_EFP(), which is analogous to global_mass_integral but returns its result in extended fixed point (EFP_type) format and always uses reproducing sums, to facilitate layout-invariant global integrals but with the potential for deferred global reductions so that this last step can be combined for various global reductions for efficiency. All answers are bitwise identical, but there is a new public interface. --- src/diagnostics/MOM_spatial_means.F90 | 45 ++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 7969ee11f8..7fc83f9b40 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -19,7 +19,7 @@ module MOM_spatial_means public :: global_i_mean, global_j_mean public :: global_area_mean, global_area_mean_u, global_area_mean_v, global_layer_mean public :: global_area_integral -public :: global_volume_mean, global_mass_integral +public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero contains @@ -234,6 +234,49 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) end function global_mass_integral +!> Find the global mass-weighted order invariant integral of a variable in mks units, +!! returning the value as an EFP_type. This uses reproducing sums. +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: var !< The variable being integrated + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, but it is still order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable + type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in + !! kg times the units of var + + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSum + real :: scalefac ! An overall scaling factor for the areas and variable. + integer :: i, j, k, is, ie, js, je, nz, isr, ier, jsr, jer + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + scalefac = GV%H_to_kg_m2 * G%US%L_to_m**2 + if (present(scale)) scalefac = scale * scalefac + + tmpForSum(:,:) = 0.0 + if (present(var)) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + var(i,j,k) * & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + endif + + global_mass_int_EFP = reproducing_sum_EFP(tmpForSum, isr, ier, jsr, jer, only_on_PE=on_PE_only) + +end function global_mass_int_EFP + !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. From 8197cea794782e5c0cedd4d200be7a8f22358bdb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Dec 2021 08:00:51 -0500 Subject: [PATCH 046/155] Use global_mass_integral in lateral_bdry_diff Use global_mass_integral for the debugging diagnostics of the tracer amounts before and after diffusion in lateral_boundary_diffusion, and replaced a call to write(*,*) with a call to MOM_mesg to actually write the message. The global_mass_integral uses reproducing sums, and is invariant to layout, while MOM_mesg is preferable for output because it will allow us to more cleanly control how output is handled and which processors do the writing. All solutions are bitwise identical, although some debugging output will change. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 36 +++++++------------ 1 file changed, 12 insertions(+), 24 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 4a98aa1934..227e3ffb06 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -8,16 +8,17 @@ 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 use MOM_checksums, only : hchksum -use MOM_domains, only : pass_var, sum_across_PEs +use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_vkernels, only : reintegrate_column -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_spatial_means, only : global_mass_integral use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -169,13 +170,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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)) :: tracer_int !< integrated tracer before LBD is applied - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G)) :: tracer_end !< integrated tracer after LBD is applied. - !! [conc H L2 ~> conc m3 or conc kg] - integer :: i, j, k, m !< indices to loop over + real :: tracer_int_prev !< Globally integrated tracer before LBD is applied, in mks units [conc kg] + real :: tracer_int_end !< Integrated tracer after LBD is applied, in mks units [conc kg] real :: Idt !< inverse of the time step [T-1 ~> s-1] - real :: tmp1, tmp2 !< temporary variables [conc H L2 ~> conc m3 or conc kg] + character(len=256) :: mesg !< Message for error messages. + integer :: i, j, k, m !< indices to loop over call cpu_clock_begin(id_clock_lbd) Idt = 1./dt @@ -236,22 +235,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) 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 - 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%name//' before/after LBD:', tmp1, tmp2 + ! tracer (native grid) integrated tracer amounts before and after LBD + tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) + tracer_int_end = global_mass_integral(h, G, GV, tracer%t) + write(mesg,*) 'Total '//tracer%name//' before/after LBD:', tracer_int_prev, tracer_int_end + call MOM_mesg(mesg) endif ! Post the tracer diagnostics From 1bf82205a981fa0ae7390d0e513cdef8315bc23c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Dec 2021 08:04:13 -0500 Subject: [PATCH 047/155] (*)+Reproducing tracer stocks Use reproducing sums for tabulating tracer stocks, and move the global sum for the tracer stocks form write_energy into call_tracer_stocks. This involves changes to the type of an argument (from real to EFP_type) for two arguments to the internal routine store_stocks. Existing tracer stock packages will still work, but to benefit from the reproducing sums, they will also have to change their reported values from real to EFP_type. This is demonstrated for two packages (advection_test_tracer and ideal_age_example), where the stocks are now found with calls to global_mass_int_EFP(), replacing the previous explicit sums. With this change, the reported stock values from these packages are identical for different PE layouts and can be much more accurate than before, but they are different from the previously reported values at roundoff (for positive-definite tracers), but it could be larger for tracers with a near-zero mean value. All solutions are bitwise identical, but output changes. --- src/diagnostics/MOM_sum_output.F90 | 4 - src/tracer/MOM_tracer_flow_control.F90 | 100 +++++++++++++++---------- src/tracer/advection_test_tracer.F90 | 23 +++--- src/tracer/ideal_age_example.F90 | 19 ++--- 4 files changed, 77 insertions(+), 69 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 668c297658..a7cae98620 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -733,10 +733,6 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci enddo ; enddo ; enddo call sum_across_PEs(CS%ntrunc) - ! Sum the various quantities across all the processors. This sum is NOT - ! guaranteed to be bitwise reproducible, even on the same decomposition. - ! The sum of Tr_stocks should be reimplemented using the reproducing sums. - if (nTr_stocks > 0) call sum_across_PEs(Tr_stocks,nTr_stocks) call max_across_PEs(max_CFL, 2) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 2ae72a3270..1941096832 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -3,21 +3,22 @@ module MOM_tracer_flow_control ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type, assignment(=), EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file -use MOM_forcing_type, only : forcing, optics_type -use MOM_get_input, only : Get_MOM_input -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type +use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file +use MOM_forcing_type, only : forcing, optics_type +use MOM_get_input, only : Get_MOM_input +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : sponge_CS -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_tracer_registry, only : tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type #include ! Add references to other user-provide tracer modules here. @@ -582,8 +583,8 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock 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) :: stock_values !< The integrated amounts of a tracer - !! on the current PE, usually in kg x concentration [kg conc]. + real, dimension(:), intent(out) :: stock_values !< The globally mass-integrated + !! amount of a tracer [kg conc]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to @@ -612,7 +613,9 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name real, dimension(MAX_FIELDS_) :: values - integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn + type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP + type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP + integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn, n if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -627,57 +630,66 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock if (CS%use_USER_tracer_example) then ns = USER_tracer_stock(h, values, G, GV, US, CS%USER_tracer_example_CSp, & names, units, stock_index) - call store_stocks("tracer_example", ns, names, units, values, index, stock_values, & + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("tracer_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif ! if (CS%use_DOME_tracer) then ! ns = DOME_tracer_stock(h, values, G, GV, CS%DOME_tracer_CSp, & ! names, units, stock_index) -! call store_stocks("DOME_tracer", ns, names, units, values, index, stock_values, & +! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo +! call store_stocks("DOME_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & ! set_pkg_name, max_ns, ns_tot, stock_names, stock_units) ! endif if (CS%use_ideal_age) then - ns = ideal_age_stock(h, values, G, GV, US, CS%ideal_age_tracer_CSp, & + ns = ideal_age_stock(h, values_EFP, G, GV, CS%ideal_age_tracer_CSp, & names, units, stock_index) - call store_stocks("ideal_age_example", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_regional_dyes) then ns = dye_stock(h, values, G, GV, US, CS%dye_tracer_CSp, & names, units, stock_index) - call store_stocks("regional_dyes", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_oil) then ns = oil_stock(h, values, G, GV, US, CS%oil_tracer_CSp, & names, units, stock_index) - call store_stocks("oil_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("oil_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_OCMIP2_CFC) then ns = OCMIP2_CFC_stock(h, values, G, GV, US, CS%OCMIP2_CFC_CSp, names, units, stock_index) - call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_CFC_cap) then ns = CFC_cap_stock(h, values, G, GV, US, CS%CFC_cap_CSp, names, units, stock_index) - call store_stocks("MOM_CFC_cap", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("MOM_CFC_cap", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_advection_test_tracer) then - ns = advection_test_stock( h, values, G, GV, US, CS%advection_test_tracer_CSp, & + ns = advection_test_stock( h, values_EFP, G, GV, CS%advection_test_tracer_CSp, & names, units, stock_index ) - call store_stocks("advection_test_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("advection_test_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_MOM_generic_tracer) then ns = MOM_generic_tracer_stock(h, values, G, GV, US, CS%MOM_generic_tracer_CSp, & names, units, stock_index) - call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& @@ -687,18 +699,26 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock if (CS%use_pseudo_salt_tracer) then ns = pseudo_salt_stock(h, values, G, GV, US, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) - call store_stocks("pseudo_salt_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("pseudo_salt_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_boundary_impulse_tracer) then ns = boundary_impulse_stock(h, values, G, GV, US, CS%boundary_impulse_tracer_CSp, & names, units, stock_index) - call store_stocks("boundary_impulse_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("boundary_impulse_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif - if (ns_tot == 0) stock_values(1) = 0.0 + ! Sum the various quantities across all the processors. + if (ns_tot > 0) then + call EFP_sum_across_PEs(stock_val_EFP, ns_tot) + do n=1,ns_tot ; stock_values(n) = EFP_to_real(stock_val_EFP(n)) ; enddo + else + stock_values(1) = 0.0 + endif if (present(num_stocks)) num_stocks = ns_tot @@ -713,11 +733,13 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, intent(in) :: names !< Diagnostic names to use for each stock. character(len=*), dimension(:), & intent(in) :: units !< Units to use in the metadata for each stock. - real, dimension(:), intent(in) :: values !< The values of the tracer stocks + type(EFP_type), dimension(:), & + intent(in) :: values !< The values of the tracer stocks integer, intent(in) :: index !< The integer stock index from !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. - real, dimension(:), intent(inout) :: stock_values !< The master list of stock values + type(EFP_type), dimension(:), & + intent(inout) :: stock_values !< The master list of stock values character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose !! stocks were stored for a specific index. This is !! used to trigger an error if there are redundant stocks. diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 8fdb525b4a..b37822823a 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -3,16 +3,18 @@ module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -75,8 +77,8 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! Local variables character(len=80) :: name, longname -! 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 = "advection_test_tracer" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -344,13 +346,12 @@ end subroutine advection_test_tracer_surface_state !> Calculate the mass-weighted integral of all tracer stocks, returning the number of stocks it has calculated. !! If the stock_index is present, only the stock corresponding to that coded index is returned. -function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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 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 + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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. @@ -359,7 +360,6 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde integer :: advection_test_stock !< the number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] 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 @@ -374,14 +374,9 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo advection_test_stock = CS%ntr diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index d5c813b3d0..5913251b14 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_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -13,6 +14,7 @@ module ideal_age_example use MOM_io, only : file_exists, MOM_read_data, 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_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -78,8 +80,8 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !! diffusion module type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! 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 = "ideal_age_example" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. @@ -369,14 +371,13 @@ end subroutine ideal_age_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it !! 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, US, CS, names, units, stock_index) +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 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 + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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. @@ -386,7 +387,6 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: ideal_age_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] 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 @@ -401,15 +401,10 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo ideal_age_stock = CS%ntr From a0d02387ecce5e6ed78b9df7028c021c0949bfa3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 Feb 2022 16:00:36 -0500 Subject: [PATCH 048/155] (*)+Use reproducing stocks for all tracer packages Modified the remaining tracer packages to use the reproducing stocks. The reported stock values from these packages will have changed slightly, but they now reproduce across PE layouts. All solutions are bitwise identical, but output changes. --- src/tracer/MOM_CFC_cap.F90 | 25 +++-------- src/tracer/MOM_OCMIP2_CFC.F90 | 60 +++++++++++--------------- src/tracer/MOM_generic_tracer.F90 | 22 +++------- src/tracer/MOM_tracer_flow_control.F90 | 29 ++++--------- src/tracer/boundary_impulse_tracer.F90 | 56 ++++++++++-------------- src/tracer/dye_example.F90 | 26 +++++------ src/tracer/oil_tracer.F90 | 57 +++++++++++------------- src/tracer/pseudo_salt_tracer.F90 | 18 +++----- src/tracer/tracer_example.F90 | 55 +++++++++++------------ 9 files changed, 137 insertions(+), 211 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 7296f1d469..c174fe4c39 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -4,6 +4,7 @@ module MOM_CFC_cap ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -14,6 +15,7 @@ module MOM_CFC_cap use MOM_io, only : vardesc, var_desc, query_vardesc, stdout use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_time_manager, only : time_type use time_interp_external_mod, only : init_external_field, time_interp_external use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -341,14 +343,13 @@ end subroutine CFC_cap_column_physics !> Calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function CFC_cap_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_(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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -357,11 +358,6 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stock being sought. integer :: CFC_cap_stock !< The number of stocks calculated here. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke CFC_cap_stock = 0 if (.not.associated(CS)) return @@ -377,15 +373,8 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="CFC_cap_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) CFC_cap_stock = 2 diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 5fe55b896b..28a9501d51 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -3,25 +3,28 @@ 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 -use MOM_forcing_type, only : forcing -use MOM_hor_index, only : hor_index_type -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, 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 -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +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 +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher +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_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -478,14 +481,13 @@ end subroutine OCMIP2_CFC_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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_(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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -494,11 +496,6 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stock being sought. integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke OCMIP2_CFC_stock = 0 if (.not.associated(CS)) return @@ -514,15 +511,8 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) OCMIP2_CFC_stock = 2 diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index f8c0f6ac06..31acb51160 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -29,7 +29,7 @@ module MOM_generic_tracer 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_coms, only : EFP_type, 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 @@ -40,7 +40,7 @@ module MOM_generic_tracer 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_spatial_means, only : global_area_mean, global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut @@ -568,13 +568,12 @@ end subroutine MOM_generic_tracer_column_physics !! being requested specifically, returning the number of stocks it has !! calculated. If the stock_index is present, only the stock corresponding !! to that coded index is returned. - function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) + 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_(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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), 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. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. @@ -584,14 +583,12 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ !! number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr 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 = GV%ke + integer :: m MOM_generic_tracer_stock = 0 if (.not.associated(CS)) return @@ -605,7 +602,6 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 m=1 ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) @@ -613,12 +609,8 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ units(m) = trim(units(m))//" kg" call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - stocks(m) = 0.0 tr_ptr => tr_field(:,:,:,1) - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + tr_ptr(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, tr_ptr, on_PE_only=.true.) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 1941096832..ce747bba01 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -612,7 +612,7 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! Local variables character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name - real, dimension(MAX_FIELDS_) :: values + ! real, dimension(MAX_FIELDS_) :: values type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn, n @@ -628,9 +628,8 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! Add other user-provided calls here. if (CS%use_USER_tracer_example) then - ns = USER_tracer_stock(h, values, G, GV, US, CS%USER_tracer_example_CSp, & + ns = USER_tracer_stock(h, values_EFP, G, GV, CS%USER_tracer_example_CSp, & names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo call store_stocks("tracer_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif @@ -644,34 +643,27 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock if (CS%use_ideal_age) then ns = ideal_age_stock(h, values_EFP, G, GV, CS%ideal_age_tracer_CSp, & names, units, stock_index) - ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_regional_dyes) then - ns = dye_stock(h, values, G, GV, US, CS%dye_tracer_CSp, & - names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + ns = dye_stock(h, values_EFP, G, GV, CS%dye_tracer_CSp, names, units, stock_index) call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_oil) then - ns = oil_stock(h, values, G, GV, US, CS%oil_tracer_CSp, & - names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + ns = oil_stock(h, values_EFP, G, GV, CS%oil_tracer_CSp, names, units, stock_index) call store_stocks("oil_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_OCMIP2_CFC) then - ns = OCMIP2_CFC_stock(h, values, G, GV, US, CS%OCMIP2_CFC_CSp, names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + ns = OCMIP2_CFC_stock(h, values_EFP, G, GV, CS%OCMIP2_CFC_CSp, names, units, stock_index) call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_CFC_cap) then - ns = CFC_cap_stock(h, values, G, GV, US, CS%CFC_cap_CSp, names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + ns = CFC_cap_stock(h, values_EFP, G, GV, CS%CFC_cap_CSp, names, units, stock_index) call store_stocks("MOM_CFC_cap", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif @@ -685,9 +677,8 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock endif if (CS%use_MOM_generic_tracer) then - ns = MOM_generic_tracer_stock(h, values, G, GV, US, CS%MOM_generic_tracer_CSp, & + ns = MOM_generic_tracer_stock(h, values_EFP, G, GV, CS%MOM_generic_tracer_CSp, & names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 @@ -697,17 +688,15 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock endif if (CS%use_pseudo_salt_tracer) then - ns = pseudo_salt_stock(h, values, G, GV, US, CS%pseudo_salt_tracer_CSp, & + ns = pseudo_salt_stock(h, values_EFP, G, GV, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo call store_stocks("pseudo_salt_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_boundary_impulse_tracer) then - ns = boundary_impulse_stock(h, values, G, GV, US, CS%boundary_impulse_tracer_CSp, & + ns = boundary_impulse_stock(h, values_EFP, G, GV, CS%boundary_impulse_tracer_CSp, & names, units, stock_index) - do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo call store_stocks("boundary_impulse_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index ea60a09608..44423b5650 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -3,24 +3,26 @@ 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 -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 : 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 -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : 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_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -287,13 +289,12 @@ end subroutine boundary_impulse_tracer_column_physics !> This function calculates the mass-weighted integral of the boundary impulse, !! tracer stocks returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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_(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(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + type(EFP_type), 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 !! call to register_boundary_impulse_tracer. character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. @@ -302,14 +303,8 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in !! being sought. integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m boundary_impulse_stock = 0 if (.not.associated(CS)) return @@ -322,15 +317,10 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,1 call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo boundary_impulse_stock = CS%ntr diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dca01e974a..d7c7a7bad3 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_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -13,6 +14,7 @@ module regional_dyes 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_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -74,13 +76,13 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! structure for the tracer advection and diffusion module. type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! Local variables -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "regional_dyes" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. + ! This include declares and sets the variable "version". +# include "version_variable.h" real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_dye_tracer integer :: isd, ied, jsd, jed, nz, m @@ -325,13 +327,12 @@ end subroutine dye_tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function dye_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_(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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(dye_tracer_CS), pointer :: CS !< The control structure returned by a !! previous call to register_dye_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -342,9 +343,7 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m dye_stock = 0 if (.not.associated(CS)) return @@ -357,15 +356,10 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo dye_stock = CS%ntr diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 6f690ab760..0c5a4e6e8d 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -3,24 +3,27 @@ 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 -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, MOM_read_data, 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 -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +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_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -81,7 +84,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "oil_tracer" ! This module's name. -! This include declares and sets the variable "version". + ! This include declares and sets the variable "version". # include "version_variable.h" real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] character(len=200) :: inputdir ! The directory where the input files are. @@ -402,13 +405,12 @@ end subroutine oil_tracer_column_physics !> Calculate the mass-weighted integral of the oil tracer stocks, returning the number of stocks it !! has calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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_(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(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(EFP_type), 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 !! call to register_oil_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -418,9 +420,7 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: oil_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m oil_stock = 0 if (.not.associated(CS)) return @@ -433,15 +433,10 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo oil_stock = CS%ntr diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index c441e519be..6c22daa150 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -3,6 +3,7 @@ module pseudo_salt_tracer ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_debugging, only : hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl @@ -14,6 +15,7 @@ module pseudo_salt_tracer 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_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -253,13 +255,12 @@ end subroutine pseudo_salt_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it has !! calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated @@ -269,10 +270,6 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: pseudo_salt_stock !< Return value: the number of !! stocks calculated here - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pseudo_salt_stock = 0 if (.not.associated(CS)) return @@ -285,14 +282,9 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") units(1) = trim(units(1))//" kg" - stocks(1) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(1) = stocks(1) + CS%diff(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%diff, on_PE_only=.true.) pseudo_salt_stock = 1 diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index a41f0ab76d..3848b84eff 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -3,22 +3,25 @@ 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 -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, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -64,8 +67,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Local variables character(len=80) :: name, longname -! 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 = "tracer_example" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -358,14 +361,13 @@ end subroutine tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +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_(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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a !! previous call to register_USER_tracer. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -376,9 +378,7 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m USER_tracer_stock = 0 if (.not.associated(CS)) return @@ -390,15 +390,10 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,NTR call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo USER_tracer_stock = NTR From a468bee03702df5816a02580b5f46d9fcca971b1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 23 Feb 2022 16:31:16 -0500 Subject: [PATCH 049/155] Removed trailing white space Removed trailing white space on two lines. All answers are bitwise identical. --- src/core/MOM_checksum_packages.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 3951dfdc7d..d9855a98d3 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -294,8 +294,8 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe T%average = T%average + dV*Temp(i,j,k) S%minimum = min( S%minimum, Salt(i,j,k) ) ; S%maximum = max( S%maximum, Salt(i,j,k) ) S%average = S%average + dV*Salt(i,j,k) - tmp_T(i,j) = tmp_T(i,j) + dV*Temp(i,j,k) - tmp_S(i,j) = tmp_S(i,j) + dV*Salt(i,j,k) + tmp_T(i,j) = tmp_T(i,j) + dV*Temp(i,j,k) + tmp_S(i,j) = tmp_S(i,j) + dV*Salt(i,j,k) endif if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif From b3e80f73f1033dd88ebc2d362d941a0f2a58d151 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 27 Feb 2022 13:46:00 -0500 Subject: [PATCH 050/155] +(*)Add tmp_scale arguments to global_area_mean Added new tmp_scale optional arguments to global_area_mean, global_layer_mean, global_area_mean_u, global_area_mean_v, global_area_integral, global_volume_mean and global_mass_integral. This argument allows the reproducing sums to work with rescaled variables without undoing the scaling of the returned variable. Also corrected the area_rescaling in global_area_mean_u and global_area_mean_v, which were substantially changing answers when horizontal distances were being rescaled (i.e., if L_RESCALE_POWER is not 0). These routines had only been added recently, so this change is only changing answers with HOMOGENIZE_FORCINGS = True. --- src/diagnostics/MOM_spatial_means.F90 | 105 +++++++++++++++++++------- 1 file changed, 78 insertions(+), 27 deletions(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 7fc83f9b40..551b821645 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -25,89 +25,121 @@ module MOM_spatial_means contains !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var, G, scale) +function global_area_mean(var, G, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average real, optional, intent(in) :: scale !< A rescaling factor for the variable - - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_area_mean + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo + global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean = global_area_mean / temp_scale + end function global_area_mean !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean_v(var, G) +function global_area_mean_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean_v + + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming + real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + tmpForSumming(:,:) = 0. do J=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * (var(i,J) * G%mask2dCv(i,J) + & - var(i,J-1) * G%mask2dCv(i,J-1)) & - / max(1.e-20,G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(i,J) * G%mask2dCv(i,J) + var(i,J-1) * G%mask2dCv(i,J-1)) / & + max(1.e-20, G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) enddo ; enddo global_area_mean_v = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_v = global_area_mean_v / temp_scale end function global_area_mean_v !> Return the global area mean of a variable on U grid. This uses reproducing sums. -function global_area_mean_u(var, G) +function global_area_mean_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G), SZJ_(G)), intent(in) :: var !< The variable to average + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value + real :: global_area_mean_u real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: global_area_mean_u + real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * (var(I,j) * G%mask2dCu(I,j) + & - var(I-1,j) * G%mask2dCu(I-1,j)) & - / max(1.e-20,G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(I,j) * G%mask2dCu(I,j) + var(I-1,j) * G%mask2dCu(I-1,j)) / & + max(1.e-20, G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) enddo ; enddo global_area_mean_u = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_u = global_area_mean_u / temp_scale end function global_area_mean_u !> Return the global area integral of a variable, by default using the masked area from the !! grid, but an alternate could be used instead. This uses reproducing sums. -function global_area_integral(var, G, scale, area) +function global_area_integral(var, G, scale, area, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including - !! any required masking [L2 ~> m2]. + !! any required masking [L2 ~> m2]. + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0. if (present(area)) then @@ -119,27 +151,35 @@ function global_area_integral(var, G, scale, area) tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo endif + global_area_integral = reproducing_sum(tmpForSumming) + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_integral = global_area_integral / temp_scale + end function global_area_integral !> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. -function global_layer_mean(var, h, G, GV, scale) +function global_layer_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real, dimension(SZK_(GV)) :: global_layer_mean real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight type(EFP_type), dimension(2*SZK_(GV)) :: laysums real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar + real :: temp_scale ! A temporary scaling factor real :: scalefac ! A scaling factor for the variable. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = scale * temp_scale tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -152,13 +192,13 @@ function global_layer_mean(var, h, G, GV, scale) call EFP_sum_across_PEs(laysums, 2*nz) do k=1,nz - global_layer_mean(k) = EFP_to_real(laysums(k)) / EFP_to_real(laysums(nz+k)) + global_layer_mean(k) = EFP_to_real(laysums(k)) / (temp_scale * EFP_to_real(laysums(nz+k))) enddo end function global_layer_mean !> Find the global thickness-weighted mean of a variable. This uses reproducing sums. -function global_volume_mean(var, h, G, GV, scale) +function global_volume_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -166,15 +206,19 @@ function global_volume_mean(var, h, G, GV, scale) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_volume_mean !< The thickness-weighted average of var + real :: temp_scale ! A temporary scaling factor real :: scalefac ! A scaling factor for the variable. real :: weight_here real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming, sum_weight integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = temp_scale * scale tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -183,13 +227,13 @@ function global_volume_mean(var, h, G, GV, scale) sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo global_volume_mean = (reproducing_sum(tmpForSumming)) / & - (reproducing_sum(sum_weight)) + (temp_scale * reproducing_sum(sum_weight)) end function global_volume_mean !> Find the global mass-weighted integral of a variable. This uses reproducing sums. -function global_mass_integral(h, G, GV, var, on_PE_only, scale) +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -199,16 +243,20 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only !! done on the local PE, and it is _not_ order invariant. real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_mass_integral !< The mass-weighted integral of var (or 1) in !! kg times the units of var real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. logical :: global_sum integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0.0 if (present(var)) then @@ -232,6 +280,9 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) enddo ; enddo endif + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_mass_integral = global_mass_integral / temp_scale + end function global_mass_integral !> Find the global mass-weighted order invariant integral of a variable in mks units, From fa2832c1154f95a7af60c3aa51580f1abe4d7412 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 27 Feb 2022 13:53:37 -0500 Subject: [PATCH 051/155] +(*)Rescale variables with homogenize_forcing Add optional tmp_scale arguments to the various homogenize_field routines and use them in numerous calls in homogenize_forcing and homogenize_mech_forcing, so that the answers will pass the dimensional rescaling tests for large rescaling factors when HOMOGENIZE_FORCINGS = True. Among other changes is the addition of a verticalGrid_type argument to homogenize_forcing. All answers are bitwise identical in the existing MOM6-examples test suite, but it will change answers in other cases with dimensional rescaling active and homogenized forcing. --- src/core/MOM.F90 | 2 +- src/core/MOM_forcing_type.F90 | 151 ++++++++++++++++++---------------- 2 files changed, 81 insertions(+), 72 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4a82eac903..8f6dab2a1a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -591,7 +591,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call homogenize_mech_forcing(forces, G, US, GV%Rho0, CS%update_ustar) ! Note the following computes the mean ustar as the mean of ustar rather than ! ustar of the mean of tau. - call homogenize_forcing(fluxes, G) + call homogenize_forcing(fluxes, G, GV, US) if (CS%update_ustar) then ! These calls corrects the ustar values call copy_common_forcing_fields(forces, fluxes, G) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3248c09fa4..be40f7bcb7 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3472,9 +3472,9 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], - !! as used to calculate ustar. + !! as used to calculate ustar. logical, optional, intent(in) :: UpdateUstar !< A logical to determine if Ustar should be directly averaged - !! or updated from mean tau. + !! or updated from mean tau. real :: tx_mean, ty_mean, avg real :: iRho0 @@ -3492,52 +3492,54 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) do_press, do_iceberg) if (do_stress) then - tx_mean = global_area_mean_u(forces%taux, G) + tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=js,je ; do i=isB,ieB if (G%mask2dCu(I,j) > 0.) forces%taux(I,j) = tx_mean enddo ; enddo - ty_mean = global_area_mean_v(forces%tauy, G) + ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=jsB,jeB ; do i=is,ie if (G%mask2dCv(i,J) > 0.) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*iRho0) + if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = US%L_to_Z*sqrt(sqrt(tx_mean**2 + ty_mean**2)*iRho0) enddo ; enddo else - call homogenize_field_t(forces%ustar, G) + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) endif else if (do_ustar) then - call homogenize_field_t(forces%ustar, G) + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) endif endif if (do_shelf) then - call homogenize_field_u(forces%rigidity_ice_u, G) - call homogenize_field_v(forces%rigidity_ice_v, G) + call homogenize_field_u(forces%rigidity_ice_u, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_v(forces%rigidity_ice_v, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) call homogenize_field_u(forces%frac_shelf_u, G) call homogenize_field_v(forces%frac_shelf_v, G) endif if (do_press) then ! NOTE: p_surf_SSH either points to p_surf or p_surf_full - call homogenize_field_t(forces%p_surf, G) - call homogenize_field_t(forces%p_surf_full, G) - call homogenize_field_t(forces%net_mass_src, G) + call homogenize_field_t(forces%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%net_mass_src, G, tmp_scale=US%RZ_T_to_kg_m2s) endif if (do_iceberg) then call homogenize_field_t(forces%area_berg, G) - call homogenize_field_t(forces%mass_berg, G) + call homogenize_field_t(forces%mass_berg, G, tmp_scale=US%RZ_to_kg_m2) endif end subroutine homogenize_mech_forcing !< Homogenize the fluxes -subroutine homogenize_forcing(fluxes, G) - type(forcing), intent(inout) :: fluxes !< Input forcing struct - type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing +subroutine homogenize_forcing(fluxes, G, GV, US) + type(forcing), intent(inout) :: fluxes !< Input forcing struct + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real :: avg logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & @@ -3550,97 +3552,98 @@ subroutine homogenize_forcing(fluxes, G) do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) if (do_ustar) then - call homogenize_field_t(fluxes%ustar, G) - call homogenize_field_t(fluxes%ustar_gustless, G) + call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) endif if (do_water) then - call homogenize_field_t(fluxes%evap, G) - call homogenize_field_t(fluxes%lprec, G) - call homogenize_field_t(fluxes%lprec, G) - call homogenize_field_t(fluxes%fprec, G) - call homogenize_field_t(fluxes%vprec, G) - call homogenize_field_t(fluxes%lrunoff, G) - call homogenize_field_t(fluxes%frunoff, G) - call homogenize_field_t(fluxes%seaice_melt, G) - call homogenize_field_t(fluxes%netMassOut, G) - call homogenize_field_t(fluxes%netMassIn, G) + call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + ! These two calls might not be needed. + call homogenize_field_t(fluxes%netMassOut, G, tmp_scale=GV%H_to_mks) + call homogenize_field_t(fluxes%netMassIn, G, tmp_scale=GV%H_to_mks) !This was removed and I don't think replaced. Not needed? !call homogenize_field_t(fluxes%netSalt, G) endif if (do_heat) then - call homogenize_field_t(fluxes%seaice_melt_heat, G) - call homogenize_field_t(fluxes%sw, G) - call homogenize_field_t(fluxes%lw, G) - call homogenize_field_t(fluxes%latent, G) - call homogenize_field_t(fluxes%sens, G) - call homogenize_field_t(fluxes%latent_evap_diag, G) - call homogenize_field_t(fluxes%latent_fprec_diag, G) - call homogenize_field_t(fluxes%latent_frunoff_diag, G) + call homogenize_field_t(fluxes%seaice_melt_heat, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + !### These are for diagnostics only and may not be needed. + call homogenize_field_t(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) endif - if (do_salt) call homogenize_field_t(fluxes%salt_flux, G) + if (do_salt) call homogenize_field_t(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) if (do_heat .and. do_water) then - call homogenize_field_t(fluxes%heat_content_cond, G) - call homogenize_field_t(fluxes%heat_content_icemelt, G) - call homogenize_field_t(fluxes%heat_content_lprec, G) - call homogenize_field_t(fluxes%heat_content_fprec, G) - call homogenize_field_t(fluxes%heat_content_vprec, G) - call homogenize_field_t(fluxes%heat_content_lrunoff, G) - call homogenize_field_t(fluxes%heat_content_frunoff, G) - call homogenize_field_t(fluxes%heat_content_massout, G) - call homogenize_field_t(fluxes%heat_content_massin, G) + call homogenize_field_t(fluxes%heat_content_cond, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_icemelt, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_fprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) endif - if (do_press) call homogenize_field_t(fluxes%p_surf, G) + if (do_press) call homogenize_field_t(fluxes%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) if (do_shelf) then call homogenize_field_t(fluxes%frac_shelf_h, G) - call homogenize_field_t(fluxes%ustar_shelf, G) - call homogenize_field_t(fluxes%iceshelf_melt, G) + call homogenize_field_t(fluxes%ustar_shelf, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%iceshelf_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) endif if (do_iceberg) then - call homogenize_field_t(fluxes%ustar_berg, G) + call homogenize_field_t(fluxes%ustar_berg, G, tmp_scale=US%Z_to_m*US%s_to_T) call homogenize_field_t(fluxes%area_berg, G) endif if (do_heat_added) then - call homogenize_field_t(fluxes%heat_added, G) + call homogenize_field_t(fluxes%heat_added, G, tmp_scale=US%QRZ_T_to_W_m2) endif ! The following fields are handled by drivers rather than control flags. if (associated(fluxes%sw_vis_dir)) & - call homogenize_field_t(fluxes%sw_vis_dir, G) + call homogenize_field_t(fluxes%sw_vis_dir, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call homogenize_field_t(fluxes%sw_vis_dif, G) + call homogenize_field_t(fluxes%sw_vis_dif, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call homogenize_field_t(fluxes%sw_nir_dir, G) + call homogenize_field_t(fluxes%sw_nir_dir, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call homogenize_field_t(fluxes%sw_nir_dif, G) + call homogenize_field_t(fluxes%sw_nir_dif, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%salt_flux_in)) & - call homogenize_field_t(fluxes%salt_flux_in, G) + call homogenize_field_t(fluxes%salt_flux_in, G, tmp_scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%salt_flux_added)) & - call homogenize_field_t(fluxes%salt_flux_added, G) + call homogenize_field_t(fluxes%salt_flux_added, G, tmp_scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%p_surf_full)) & - call homogenize_field_t(fluxes%p_surf_full, G) + call homogenize_field_t(fluxes%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) if (associated(fluxes%buoy)) & - call homogenize_field_t(fluxes%buoy, G) + call homogenize_field_t(fluxes%buoy, G, tmp_scale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%TKE_tidal)) & - call homogenize_field_t(fluxes%TKE_tidal, G) + call homogenize_field_t(fluxes%TKE_tidal, G, tmp_scale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call homogenize_field_t(fluxes%ustar_tidal, G) + call homogenize_field_t(fluxes%ustar_tidal, G, tmp_scale=US%Z_to_m*US%s_to_T) ! TODO: tracer flux homogenization ! Having a warning causes a lot of errors (each time step). @@ -3649,45 +3652,51 @@ subroutine homogenize_forcing(fluxes, G) end subroutine homogenize_forcing -subroutine homogenize_field_t(var, G) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(inout) :: var !< The variable to homogenize +subroutine homogenize_field_t(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: avg integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - avg = global_area_mean(var, G) + avg = global_area_mean(var, G, tmp_scale=tmp_scale) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.) var(i,j) = avg enddo ; enddo end subroutine homogenize_field_t -subroutine homogenize_field_v(var, G) +subroutine homogenize_field_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: avg integer :: i, j, is, ie, jsB, jeB is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB - avg = global_area_mean_v(var, G) + avg = global_area_mean_v(var, G, tmp_scale=tmp_scale) do J=jsB,jeB ; do i=is,ie if (G%mask2dCv(i,J) > 0.) var(i,J) = avg enddo ; enddo end subroutine homogenize_field_v -subroutine homogenize_field_u(var, G) +subroutine homogenize_field_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: avg integer :: i, j, isB, ieB, js, je isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec - avg = global_area_mean_u(var, G) + avg = global_area_mean_u(var, G, tmp_scale=tmp_scale) do j=js,je ; do I=isB,ieB if (G%mask2dCu(I,j) > 0.) var(I,j) = avg enddo ; enddo From 9caa7010fc1e57c48cb2549fc174062d22b9ffd8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 23 Feb 2022 10:31:29 -0500 Subject: [PATCH 052/155] (+) Refactor of MOM_file_parser This patch includes several minor changes to the MOM_file_parser and supporting modules in order to accommodate stronger unit testing. It includes the following API changes: - Removal of `static_value` from `get_param` - Redefined `link_parameter` and `parameter_block` as private - New functions: `all_across_PEs()`, `any_across_PEs()` `static_value` was not used in any known experiments (outside of internal GFDL testing), and the two derived types describe internal operations within `MOM_file_parser`, so we do not expect any disruptions from these changes. A detailed summary of the changes are listed below. - `assert()` is now used to detect same files with different IO units. Detection of reopenend files of the same name but different IO unit has been changed from `MOM_error(FATAL, ...)` to `assert()`, to reflect that this should be a logically impossible result. - Bugfix: Reopened files are now reported to all PEs. If an open file is re-opened, then only the root PE will detect this and will `return` immediately. However, the others will proceed into `populate_param_data` and will get stuck in a broadcast waiting for root. We fix this by communicating the reopened state to all PEs and allow all ranks to return before re-processing the data. Note that this could also be resolved by allowing all ranks to track IO unit numbers, but for now we do not attempt to change this behavior. - `newunit=` used to generate parameter file IO unit The parameter IO unit is now generated by `newunit=` rather than an explicit search for an unused IO unit. Note that this is a Fortran 2008 feature. Testing around available IO units has also been removed. - Removal of generic IO error handling Generic "IO error" tests, and corresponding `err=` arguments, have been removed in most cases. We now rely on the Fortran runtime to provide diagnostics on these errors, which should typically exceed any information that MOM6 could provide. - Removal of purported `namelist` support There were several blocks of code provided to support namelist syntax, but did not appear to be working, nor was there any known instance of it being used by anyone, so it has been removed. - `#define/undef/=` syntax testing across ranks Previously, only the root PE would test for consistency of the #define-like syntax, even though all ranks have this information. This required a second, awkwardly placed syntax test later in the subroutine. This test is redefined to run over all ranks, and the subsequent test has been removed. - `define/override` test reordering The `found_override` test when coupled to a `#define`-like declaration was unreachable due to the presence of an even stronger test related to valid syntax. This test has been moved to provide more detailed information about the nature of the error. - `link_parameter`, `parameter_block` defined as private Internal derived types of `MOM_file_parser` are redefined as private. This preserves the integrity of instances of these types, and also prevents creation of implicit object code required to access them externally. - Removal of `static_value` from `get_param` interface The `static_value` argument of `get_param` has been removed, since it is functionally equivalent to `default`. While this is an API change, there is no known case of anyone using this argument. - The `param_type%doc` fields are now properly deallocated after closed. - Quotes have been added around some filename error warnings, to help detect issues related to whitespace. - `any_across_PEs` and `all_across_PEs` New functions for calling `any()` and `all()` across PE ranks have been added. Behavior is in line with other functions, such as `min_across_PEs`. --- config_src/infra/FMS1/MOM_coms_infra.F90 | 31 ++++ config_src/infra/FMS2/MOM_coms_infra.F90 | 31 ++++ src/core/MOM_verticalGrid.F90 | 2 +- src/framework/MOM_coms.F90 | 2 + src/framework/MOM_domains.F90 | 8 +- src/framework/MOM_file_parser.F90 | 186 +++++++---------------- 6 files changed, 123 insertions(+), 137 deletions(-) diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 index 555b4df119..561cf6c333 100644 --- a/config_src/infra/FMS1/MOM_coms_infra.F90 +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -16,6 +16,7 @@ module MOM_coms_infra 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 :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -438,6 +439,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> 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) diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index 555b4df119..561cf6c333 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -16,6 +16,7 @@ module MOM_coms_infra 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 :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -438,6 +439,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> 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) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index b856cff3dc..a340b5f80f 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -142,7 +142,7 @@ subroutine verticalGridInit( param_file, GV, US ) ! Here NK_ is a macro, while nk is a variable. call get_param(param_file, mdl, "NK", nk, & "The number of model layers.", units="nondim", & - static_value=NK_) + default=NK_) if (nk /= NK_) call MOM_error(FATAL, "verticalGridInit: " // & "Mismatched number of layers NK_ between MOM_memory.h and param_file") diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index c3ed3ba7b3..9e4b811a46 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -7,12 +7,14 @@ module MOM_coms use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, 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 +use MOM_coms_infra, only : all_across_PEs, any_across_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING 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 :: all_across_PEs, any_across_PEs public :: set_PElist, Get_PElist, Set_rootPE 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 diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 0cdcc455fc..dc6c0a8996 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -220,11 +220,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & 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) + default=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) + default=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: " // & @@ -256,11 +256,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & 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) + default=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) + default=njhalo_dflt) if (present(min_halo)) then n_halo(1) = max(n_halo(1), min_halo(1)) min_halo(1) = n_halo(1) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 07e9138594..3ad551496f 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -4,7 +4,8 @@ module MOM_file_parser ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : root_PE, broadcast -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_coms, only : any_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, assert use MOM_error_handler, only : is_root_pe, stdlog, stdout use MOM_time_manager, only : get_time, time_type, get_ticks_per_second use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time @@ -39,14 +40,14 @@ module MOM_file_parser end type file_data_type !> A link in the list of variables that have already had override warnings issued -type :: link_parameter ; private +type, private :: link_parameter ; private type(link_parameter), pointer :: next => NULL() !< Facilitates linked list character(len=80) :: name !< Parameter name logical :: hasIssuedOverrideWarning = .false. !< Has a default value end type link_parameter !> Specify the active parameter block -type :: parameter_block ; private +type, private :: parameter_block ; private character(len=240) :: name = '' !< The active parameter block name end type parameter_block @@ -125,7 +126,7 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! the documentation files. The default is effectively './'. ! Local variables - logical :: file_exists, unit_in_use, Netcdf_file, may_check + logical :: file_exists, unit_in_use, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path type(parameter_block), pointer :: block => NULL() @@ -140,30 +141,29 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) ! Check that this file has not already been opened if (CS%nfiles > 0) then + reopened_file = .false. inquire(file=trim(filename), number=iounit) if (iounit /= -1) then do i = 1, CS%nfiles if (CS%iounit(i) == iounit) then - if (trim(CS%filename(1)) /= trim(filename)) then - call MOM_error(FATAL, & + call assert(trim(CS%filename(1)) == trim(filename), & "open_param_file: internal inconsistency! "//trim(filename)// & " is registered as open but has the wrong unit number!") - else - call MOM_error(WARNING, & + call MOM_error(WARNING, & "open_param_file: file "//trim(filename)// & " has already been opened. This should NOT happen!"// & " Did you specify the same file twice in a namelist?") - return - endif ! filenames + reopened_file = .true. endif ! unit numbers enddo ! i endif + if (any_across_PEs(reopened_file)) return endif ! Check that the file exists to readstdlog inquire(file=trim(filename), exist=file_exists) if (.not.file_exists) call MOM_error(FATAL, & - "open_param_file: Input file "// trim(filename)//" does not exist.") + "open_param_file: Input file '"// trim(filename)//"' does not exist.") Netcdf_file = .false. if (strlen > 3) then @@ -174,18 +174,10 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) call MOM_error(FATAL,"open_param_file: NetCDF files are not yet supported.") if (all_PEs_read .or. is_root_pe()) then - ! Find an unused unit number. - do iounit=10,512 - INQUIRE(iounit,OPENED=unit_in_use) ; if (.not.unit_in_use) exit - enddo - if (iounit >= 512) call MOM_error(FATAL, & - "open_param_file: No unused file unit could be found.") - - ! Open the parameter file. - open(iounit, file=trim(filename), access='SEQUENTIAL', & + open(newunit=iounit, file=trim(filename), access='SEQUENTIAL', & form='FORMATTED', action='READ', position='REWIND', iostat=ios) - if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening "// & - trim(filename)) + if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"// & + trim(filename)//"'.") else iounit = 1 endif @@ -268,6 +260,7 @@ subroutine close_param_file(CS, quiet_close, component) enddo CS%log_open = .false. call doc_end(CS%doc) + deallocate(CS%doc) return endif ; endif @@ -341,7 +334,7 @@ subroutine close_param_file(CS, quiet_close, component) CS%log_open = .false. call doc_end(CS%doc) - + deallocate(CS%doc) end subroutine close_param_file !> Read the contents of a parameter input file, and store the contents in a @@ -361,8 +354,6 @@ subroutine populate_param_data(iounit, filename, param_data) ! Allocate the space to hold the lines in param_data%line ! Populate param_data%line with the keyword lines from parameter file - if (iounit <= 0) return - if (all_PEs_read .or. is_root_pe()) then ! rewind the parameter file rewind(iounit) @@ -371,7 +362,7 @@ subroutine populate_param_data(iounit, filename, param_data) num_lines = 0 inMultiLineComment = .false. do while(.true.) - read(iounit, '(a)', end=8, err=9) line + read(iounit, '(a)', end=8) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. @@ -410,7 +401,7 @@ subroutine populate_param_data(iounit, filename, param_data) ! Populate param_data%line num_lines = 0 do while(.true.) - read(iounit, '(a)', end=18, err=9) line + read(iounit, '(a)', end=18) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. @@ -426,21 +417,15 @@ subroutine populate_param_data(iounit, filename, param_data) enddo ! while (.true.) 18 continue ! get here when read() reaches EOF - if (num_lines /= param_data%num_lines) & - call MOM_error(FATAL, 'MOM_file_parser : Found different number of '// & - 'valid lines on second reading of '//trim(filename)) + call assert(num_lines == param_data%num_lines, & + 'MOM_file_parser: Found different number of valid lines on second ' & + // 'reading of '//trim(filename)) endif ! (is_root_pe()) ! Broadcast the populated array param_data%line if (.not. all_PEs_read) then call broadcast(param_data%line, INPUT_STR_LENGTH, root_pe()) endif - - return - -9 call MOM_error(FATAL, "MOM_file_parser : "//& - "Error while reading file "//trim(filename)) - end subroutine populate_param_data @@ -911,7 +896,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName character(len=FILENAME_LENGTH) :: filename - integer :: is, id, isd, isu, ise, iso, verbose, ipf + integer :: is, id, isd, isu, ise, iso, ipf integer :: last, last1, ival, oval, max_vals, count, contBufSize character(len=52) :: set logical :: found_override, found_equals @@ -920,10 +905,10 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL logical :: variableKindIsLogical, valueIsSame logical :: inWrongBlock, fullPathParameter logical, parameter :: requireNamedClose = .false. + integer, parameter :: verbose = 1 set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" continuationBuffer = repeat(" ",INPUT_STR_LENGTH) contBufSize = 0 - verbose = 1 variableKindIsLogical=.false. if (present(paramIsLogical)) variableKindIsLogical = paramIsLogical @@ -986,25 +971,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL line = trim(adjustl(line(iso+10:last))); last = len_trim(line) endif - ! Check for start of fortran namelist, ie. '&namelist' - if (index(line(:last),'&')==1) then - iso=index(line(:last),' ') - if (iso>0) then ! possibly simething else on this line - blockName = pushBlockLevel(blockName,line(2:iso-1)) - line=trim(adjustl(line(iso:last))) - last=len_trim(line) - if (last==0) cycle ! nothing else on this line - else ! just the namelist on this line - if (len_trim(blockName)>0) then - blockName = trim(blockName) // '%' //trim(line(2:last)) - else - blockName = trim(line(2:last)) - endif - call flag_line_as_read(CS%param_data(ipf)%line_used,count) - cycle - endif - endif - ! Newer form of parameter block, block%, %block or block%param or iso=index(line(:last),'%') fullPathParameter = .false. @@ -1042,14 +1008,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL if (trim(CS%blockName%name)/=trim(blockName)) inWrongBlock = .true. ! Not in the required block endif - ! Check for termination of a fortran namelist (with a '/') - if (line(last:last)=='/') then - if (len_trim(blockName)==0 .and. is_root_pe()) call MOM_error(FATAL, & - 'get_variable_line: An extra namelist/block end was encountered. Line="'// & - trim(line(:last))//'"' ) - blockName = popBlockLevel(blockName) - last = last - 1 ! Ignore the termination character from here on - endif if (inWrongBlock .and. .not. fullPathParameter) then if (index(" "//line(:last+1), " "//trim(varname)//" ")>0) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & @@ -1069,29 +1027,28 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL if (index(line(:last), "#undef ")==1) found_undef = .true. ! Check for missing, mutually exclusive or incomplete keywords - if (is_root_pe()) then - if (.not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : the parameter name '"// & - trim(varname)//"' was found without define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_define .and. found_undef) call MOM_error(FATAL, & - "MOM_file_parser : Both 'undef' and 'define' occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_equals .and. (found_define .or. found_undef)) & - call MOM_error(FATAL, & - "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_override .and. .not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : override was found "// & - " without a define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") + if (.not. (found_define .or. found_undef .or. found_equals)) then + if (found_override) then + call MOM_error(FATAL, "MOM_file_parser : override was found " // & + " without a define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + else + call MOM_error(FATAL, "MOM_file_parser : the parameter name '" // & + trim(varname) // "' was found without define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + endif endif + if (found_equals .and. (found_define .or. found_undef)) & + call MOM_error(FATAL, & + "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + ! Interpret the line and collect values, if any + ! NOTE: At least one of these must be true if (found_define) then ! Move starting pointer to first letter of defined name. is = isd + 5 + scan(line(isd+6:last), set) @@ -1131,10 +1088,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL defined_in_line = .true. endif found = .true. - else - call MOM_error(FATAL, "MOM_file_parser (non-root PE?): the parameter name '"// & - trim(varname)//"' was found without an assignment, define or undef."// & - " Line: '"//trim(line(:last))//"'"//" in file "//trim(filename)//".") endif ! This line has now been used. @@ -1201,6 +1154,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ival = ival + 1 value_string(ival) = trim(val_str) defined = defined_in_line + if (verbose > 1 .and. is_root_pe()) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & " set. Line: '"//trim(line(:last))//"'"//& @@ -1628,7 +1582,7 @@ end function convert_date_to_string !! and logs it in documentation files. subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1639,9 +1593,6 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1660,7 +1611,6 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_int(CS, varname, value, fail_if_missing) endif @@ -1675,7 +1625,7 @@ end subroutine get_param_int !! and logs them in documentation files. subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1686,9 +1636,6 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1706,8 +1653,7 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_int_array(CS, varname, value, fail_if_missing) endif @@ -1722,7 +1668,7 @@ end subroutine get_param_int_array !! and logs it in documentation files. subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, debuggingParam, scale, unscaled) + debuggingParam, scale, unscaled) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1733,9 +1679,6 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1756,7 +1699,6 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_real(CS, varname, value, fail_if_missing) endif @@ -1774,7 +1716,7 @@ end subroutine get_param_real !! and logs them in documentation files. subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, debuggingParam, & - static_value, scale, unscaled) + scale, unscaled) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1785,9 +1727,6 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1807,8 +1746,7 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_real_array(CS, varname, value, fail_if_missing) endif @@ -1826,7 +1764,7 @@ end subroutine get_param_real_array !! and logs it in documentation files. subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1837,9 +1775,6 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1858,7 +1793,6 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_char(CS, varname, value, fail_if_missing) endif @@ -1872,7 +1806,7 @@ end subroutine get_param_char !> This subroutine reads the values of an array of character string model parameters !! from a parameter file and logs them in documentation files. subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, static_value) + default, fail_if_missing, do_not_read, do_not_log) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1883,9 +1817,6 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1902,8 +1833,7 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_char_array(CS, varname, value, fail_if_missing) endif @@ -1926,7 +1856,7 @@ end subroutine get_param_char_array !! and logs it in documentation files. subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1937,9 +1867,6 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter logical, optional, intent(in) :: default !< The default value of the parameter - logical, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1958,7 +1885,6 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_logical(CS, varname, value, fail_if_missing) endif @@ -1973,7 +1899,7 @@ end subroutine get_param_logical !! and logs it in documentation files. subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - timeunit, static_value, layoutParam, debuggingParam, & + timeunit, layoutParam, debuggingParam, & log_as_date) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters @@ -1985,9 +1911,6 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter type(time_type), optional, intent(in) :: default !< The default value of the parameter - type(time_type), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -2011,7 +1934,6 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format=log_date) endif From 9a01cd501d00df2c9b2b8cf3f880fd4d8336ff53 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Feb 2022 02:37:29 -0500 Subject: [PATCH 053/155] +Add ALE options mimicking Hycom Added a number of options to MOM_ALE to mimic options that are found in Hycom. By default, all answers are bitwise identical, but there are several new runtime parameters. The code changes include: . Added the ability to use a different remapping scheme for velocities than for tracers, using the new runtime parameter VELOCITY_REMAPPING_SCHEME . Added the new runtime option PARTIAL_CELL_VELOCITY_REMAP to use partial cell thicknesses for remapping at velocity points, which triggers a call to the new internal routine apply_partial_cell_mask. . Added the new internal routine mask_near_bottom_vel to allow MOM6 to mimic Hycom in zeroing out the velocities in thin layers in a bottom boundary layer with a thickness given by the new runtime parameter REMAP_VEL_MASK_BBL_THICK, while the definition of thin is specified by REMAP_VEL_MASK_H_THIN. Setting these to be negative (as is the default) avoids this. . Modified the interface to remap_all_state_vars to take just the ALE_CS, which then provides the remapping control structure that is appropriate for the tracers or velocities, rather than also passing this in as an argument. . Eliminated some unnecessary internal variables, and added others to be more explicit avoid array syntax copies in arguments. --- src/ALE/MOM_ALE.F90 | 348 ++++++++++++++++++++++++++++++-------------- 1 file changed, 239 insertions(+), 109 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 72afad16df..46669c20cb 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -10,7 +10,7 @@ module MOM_ALE ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : check_column_integrals +use MOM_debugging, only : check_column_integrals, hchksum, uvchksum use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl use MOM_diag_mediator, only : time_type, diag_update_remap_grids use MOM_diag_vkernels, only : interpolate_column, reintegrate_column @@ -64,14 +64,26 @@ module MOM_ALE logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" !! method. If False, uses the new method that !! remaps between grids described by h. + logical :: partial_cell_vel_remap !< If true, use partial cell thicknesses at velocity points + !! that are masked out where they extend below the shallower + !! of the neighboring bathymetry for remapping velocity. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid !! and the target (new) grid [T ~> s] type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays + type(remapping_CS) :: vel_remapCS !< Remapping parameters for velocities and work arrays integer :: nk !< Used only for queries, not directly by this module + real :: BBL_h_vel_mask !< The thickness of a bottom boundary layer within which velocities in + !! thin layers are zeroed out after remapping, following practice with + !! Hybgen remapping, or a negative value to avoid such filtering + !! altogether, in [H ~> m or kg m-2]. + real :: h_vel_mask !< A thickness at velocity points below which near-bottom layers are + !! zeroed out after remapping, following the practice with Hybgen + !! remapping, or a negative value to avoid such filtering altogether, + !! in [H ~> m or kg m-2]. logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. @@ -79,6 +91,7 @@ module MOM_ALE !! that recover the answers from the end of 2018. Otherwise, use more !! robust and accurate forms of mathematically equivalent expressions. + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: show_call_tree !< For debugging ! for diagnostics @@ -144,16 +157,16 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) type(ALE_CS), pointer :: CS !< Module control structure ! Local variables - real, dimension(:), allocatable :: dz - character(len=40) :: mdl = "MOM_ALE" ! This module's name. - character(len=80) :: string ! Temporary strings - real :: filter_shallow_depth, filter_deep_depth - logical :: default_2018_answers - logical :: check_reconstruction - logical :: check_remapping - logical :: force_bounds_in_subcell - logical :: local_logical - logical :: remap_boundary_extrap + real, allocatable :: dz(:) + character(len=40) :: mdl = "MOM_ALE" ! This module's name. + character(len=80) :: string, vel_string ! Temporary strings + real :: filter_shallow_depth, filter_deep_depth + logical :: default_2018_answers + logical :: check_reconstruction + logical :: check_remapping + logical :: force_bounds_in_subcell + logical :: local_logical + logical :: remap_boundary_extrap if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -174,12 +187,17 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) - ! Initialize and configure remapping + ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & + "This sets the reconstruction scheme used for vertical remapping "//& + "of velocities. By default it is the same as REMAPPING_SCHEME. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=trim(string)) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& @@ -208,6 +226,17 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & answers_2018=CS%answers_2018) + call initialize_remapping( CS%vel_remapCS, vel_string, & + boundary_extrapolation=remap_boundary_extrap, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, & + answers_2018=CS%answers_2018) + + call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & + "If true, use partial cell thicknesses at velocity points that are masked out "//& + "where they extend below the shallower of the neighboring bathymetry for "//& + "remapping velocity.", default=.false.) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & "If true, applies regridding and remapping immediately after "//& @@ -239,6 +268,21 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "code.", default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) + call get_param(param_file, mdl, "REMAP_VEL_MASK_BBL_THICK", CS%BBL_h_vel_mask, & + "A thickness of a bottom boundary layer below which velocities in thin layers "//& + "are zeroed out after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & + default=-0.001, units="m", scale=GV%m_to_H) + call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, & + "A thickness at velocity points below which near-bottom layers are zeroed out "//& + "after remapping, following practice with Hybgen remapping, or a negative value "//& + "to avoid such filtering altogether.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) + + call get_param(param_file, "MOM", "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! Keep a record of values for subsequent queries CS%nk = GV%ke @@ -307,6 +351,7 @@ subroutine ALE_end(CS) ! Deallocate memory used for the regridding call end_remapping( CS%remapCS ) + call end_regridding( CS%regridCS ) deallocate(CS) @@ -335,13 +380,10 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec - logical :: ice_shelf + integer :: nk, i, j, k, isc, iec, jsc, jec, ntr nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec - ice_shelf = present(frac_shelf_h) - if (CS%show_call_tree) call callTree_enter("ALE_main(), MOM_ALE.F90") ! These diagnostics of the state before ALE is applied are mostly used for debugging. @@ -362,11 +404,8 @@ 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) - else - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) - endif + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & + frac_shelf_h ) call check_grid( G, GV, h, 0. ) @@ -377,23 +416,30 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) if (present(dt)) then call diag_update_remap_grids(CS%diag) endif + ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, dzRegrid, & - u, v, CS%show_call_tree, dt ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, dzRegrid, u, v, & + CS%show_call_tree, dt ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. !$OMP parallel do default(shared) - do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + do k=1,nk ; do j=jsc-1,jec+1 ; do i=isc-1,iec+1 h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - if (CS%show_call_tree) call callTree_leave("ALE_main()") + if (CS%debug) then + call hchksum(h, "Post-ALE_main h", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(tv%T, "Post-ALE_main T", G%HI, haloshift=0) + call hchksum(tv%S, "Post-ALE_main S", G%HI, haloshift=0) + call uvchksum("Post-ALE_main [uv]", u, v, G%HI, haloshift=0, scale=US%L_T_to_m_s) + endif if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) + if (CS%show_call_tree) call callTree_leave("ALE_main()") end subroutine ALE_main @@ -435,8 +481,7 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars(CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, & - debug=CS%show_call_tree, dt=dt ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree, dt=dt ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") @@ -484,12 +529,12 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective ! adjustment right now is not used because it is unclear what to do with vanished layers - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust = .false. ) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h_new, 0. ) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -565,7 +610,7 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_offline_tracer_final)") @@ -607,6 +652,7 @@ subroutine check_grid( G, GV, h, threshold ) end subroutine check_grid +!### This routine does not appear to be used. !> Generates new grid subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -622,20 +668,15 @@ subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h integer :: nk, i, j, k real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! The new grid thicknesses - logical :: show_call_tree, use_ice_shelf + logical :: show_call_tree show_call_tree = .false. if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_build_grid(), MOM_ALE.F90") - use_ice_shelf = present(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 ) - else - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid ) - endif + call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. @@ -722,7 +763,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) + call remap_all_state_vars(CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -734,10 +775,9 @@ end subroutine ALE_regrid_accelerated !! This routine is called during initialization of the model at time=0, to !! remap initial conditions to the model grid. It is also called during a !! time step to update the state. -subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, OBC, & - dzInterface, u, v, debug, dt) - type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure - type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure +subroutine remap_all_state_vars(CS, G, GV, h_old, h_new, Reg, OBC, & + dzInterface, u, v, debug, dt ) + type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid @@ -757,36 +797,41 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] real, dimension(GV%ke+1) :: dz ! The change in interface heights interpolated to ! a velocity point [H ~> m or kg m-2] - real, dimension(GV%ke) :: h1 ! A column of initial thicknesses [H ~> m or kg m-2] - real, dimension(GV%ke) :: h2 ! A column of updated thicknesses [H ~> m or kg m-2] - real, dimension(GV%ke) :: u_column ! A column of properties, like tracer concentrations - ! or velocities, being remapped [various units] - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer - ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or - ! cell thickness [H T-1 ~> m s-1 or Conc kg m-2 s-1] - real, dimension(SZI_(G), SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer - ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] - real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: tr_column(GV%ke) ! A column of updated tracer concentrations + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or + ! cell thickness [H T-1 ~> m s-1 or Conc kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] + real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] + real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] + real :: v_tgt(GV%ke) ! A column of v-velocities on the target grid [L T-1 ~> m s-1] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] - logical :: show_call_tree - type(tracer_type), pointer :: Tr => NULL() + logical :: show_call_tree + type(tracer_type), pointer :: Tr => NULL() integer :: i, j, k, m, nz, ntr show_call_tree = .false. if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("remap_all_state_vars(), MOM_ALE.F90") ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dzInterface. Otherwise, ! u and v can be remapped without dzInterface - if ( .not. present(dzInterface) .and. (CS_ALE%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then + if ( .not. present(dzInterface) .and. (CS%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then call MOM_error(FATAL, "remap_all_state_vars: dzInterface must be present if using old algorithm "// & "and u/v are to be remapped") endif - if (.not.CS_ALE%answers_2018) then + if (.not.CS%answers_2018) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 @@ -794,7 +839,9 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 endif - nz = GV%ke + if (show_call_tree) call callTree_enter("remap_all_state_vars(), MOM_ALE.F90") + + nz = GV%ke ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr @@ -804,43 +851,43 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_cont(:,:,:) = 0.0 endif - ! Remap tracer + ! Remap all registered tracers, including temperature and salinity. if (ntr>0) then if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") - !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) + !$OMP parallel do default(shared) private(h1,h2,tr_column,Tr,PCM,work_conc,work_cont,work_2d) do m=1,ntr ! For each tracer Tr => Reg%Tr(m) do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge) ! Intermediate steps for tendency of tracer concentration and tracer content. if (present(dt)) then if (Tr%id_remap_conc > 0) then do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k)) * Idt + work_conc(i,j,k) = (tr_column(k) - Tr%t(i,j,k)) * Idt enddo endif if (Tr%id_remap_cont > 0 .or. Tr%id_remap_cont_2d > 0) then do k=1,GV%ke - work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + work_cont(i,j,k) = (tr_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt enddo endif endif ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + Tr%t(i,j,:) = tr_column(:) endif ; enddo ; enddo ! tendency diagnostics. if (present(dt)) then if (Tr%id_remap_conc > 0) then - call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) + call post_data(Tr%id_remap_conc, work_conc, CS%diag) endif if (Tr%id_remap_cont > 0) then - call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) + call post_data(Tr%id_remap_cont, work_cont, CS%diag) endif if (Tr%id_remap_cont_2d > 0) then do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -849,43 +896,65 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo enddo ; enddo - call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + call post_data(Tr%id_remap_cont_2d, work_2d, CS%diag) endif endif enddo ! m=1,ntr - endif ! endif for ntr > 0 + endif ! endif for ntr > 0 if (show_call_tree) call callTree_waypoint("tracers remapped (remap_all_state_vars)") + if (CS%partial_cell_vel_remap .and. (present(u) .or. present(v)) ) then + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_old(i,j,k) + enddo ; enddo ; enddo + endif + ! Remap u velocity component if ( present(u) ) then - !$OMP parallel do default(shared) private(h1,h2,dz,u_column) - do j = G%jsc,G%jec ; do I = G%iscB,G%iecB ; if (G%mask2dCu(I,j)>0.) then + + !$OMP parallel do default(shared) private(h1,h2,dz,u_src,h_mask_vel,u_tgt) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) - if (CS_ALE%remap_uv_using_old_alg) then + do k=1,nz + u_src(k) = u(I,j,k) + h1(k) = 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + h2(k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + enddo + if (CS%remap_uv_using_old_alg) then dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i+1,j,:) ) do k = 1, nz h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) endif - if (associated(OBC)) then - if (OBC%segnum_u(I,j) /= 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - h1(:) = h_old(i+1,j,:) - h2(:) = h_new(i+1,j,:) - endif + + if (CS%partial_cell_vel_remap) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h1, h_mask_vel) + call apply_partial_cell_mask(h2, h_mask_vel) + endif + + if (associated(OBC)) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + do k=1,nz ; h1(k) = h_old(i+1,j,k) ; h2(k) = h_new(i+1,j,k) ; enddo endif + endif ; endif + + ! --- Remap u profiles from the source vertical grid onto the new target grid. + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - u(I,j,:) = u_column(:) + + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k endif ; enddo ; enddo endif @@ -893,41 +962,53 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then - !$OMP parallel do default(shared) private(h1,h2,dz,u_column) - do J = G%jscB,G%jecB ; do i = G%isc,G%iec ; if (G%mask2dCv(i,j)>0.) then + !$OMP parallel do default(shared) private(h1,h2,v_src,dz,h_mask_vel,v_tgt) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) - if (CS_ALE%remap_uv_using_old_alg) then + do k=1,nz + v_src(k) = v(i,J,k) + h1(k) = 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + h2(k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + enddo + if (CS%remap_uv_using_old_alg) then dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i,j+1,:) ) do k = 1, nz h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) endif - if (associated(OBC)) then - if (OBC%segnum_v(i,J) /= 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - h1(:) = h_old(i,j+1,:) - h2(:) = h_new(i,j+1,:) - endif + if (CS%partial_cell_vel_remap) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h1, h_mask_vel) + call apply_partial_cell_mask(h2, h_mask_vel) + endif + if (associated(OBC)) then ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + do k=1,nz ; h1(k) = h_old(i,j+1,k) ; h2(k) = h_new(i,j+1,k) ; enddo endif + endif ; endif + + ! --- Remap v profiles from the source vertical grid onto the new target grid. + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - v(i,J,:) = u_column(:) + + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k endif ; enddo ; enddo endif - if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) - if ((CS_ALE%id_vert_remap_h_tendency > 0) .and. present(dt)) then + if (CS%id_vert_remap_h > 0) call post_data(CS%id_vert_remap_h, h_old, CS%diag) + if ((CS%id_vert_remap_h_tendency > 0) .and. present(dt)) then do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(CS_ALE%id_vert_remap_h_tendency, work_cont, CS_ALE%diag) + call post_data(CS%id_vert_remap_h_tendency, work_cont, CS%diag) endif if (show_call_tree) call callTree_waypoint("v remapped (remap_all_state_vars)") if (show_call_tree) call callTree_leave("remap_all_state_vars()") @@ -935,6 +1016,55 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, end subroutine remap_all_state_vars +!> Mask out thicknesses to 0 when their runing sum exceeds a specified value. +subroutine apply_partial_cell_mask(h1, h_mask) + real, dimension(:), intent(inout) :: h1 !< A column of thicknesses to be masked out after their + !! running vertical sum exceeds h_mask [H ~> m or kg m-2] + real, intent(in) :: h_mask !< The depth after which the thicknesses in h1 are + !! masked out [H ~> m or kg m-2] + ! Local variables + real :: h1_rsum ! The running sum of h1 [H ~> m or kg m-2] + integer :: k + + h1_rsum = 0.0 + do k=1,size(h1) + if (h1(k) > h_mask - h1_rsum) then + ! This thickness is reduced because it extends below the shallower neighboring bathymetry. + h1(k) = max(h_mask - h1_rsum, 0.0) + h1_rsum = h_mask + else + h1_rsum = h1_rsum + h1(k) + endif + enddo +end subroutine apply_partial_cell_mask + + +!> Zero out velocities in a column in very thin layers near the seafloor +subroutine mask_near_bottom_vel(vel, h, h_BBL, h_thin, nk) + integer, intent(in) :: nk !< The number of layers in this column + real, intent(inout) :: vel(nk) !< The velocity component being zeroed out [L T-1 ~> m s-1] + real, intent(in) :: h(nk) !< The layer thicknesses at velocity points [H ~> m or kg m-2] + real, intent(in) :: h_BBL !< The thickness of the near-bottom region over which to apply + !! the filtering [H ~> m or kg m-2] + real, intent(in) :: h_thin !< A layer thickness below which the filtering is applied [H ~> m or kg m-2] + + ! Local variables + real :: h_from_bot ! The distance between the top of a layer and the seafloor [H ~> m or kg m-2] + integer :: k + + if ((h_BBL < 0.0) .or. (h_thin < 0.0)) return + + h_from_bot = 0.0 + do k=nk,1,-1 + h_from_bot = h_from_bot + h(k) + if (h_from_bot > h_BBL) return + ! Set the velocity to zero in thin, near-bottom layers. + if (h(k) <= h_thin) vel(k) = 0.0 + enddo !k + +end subroutine mask_near_bottom_vel + + !> Remaps a single scalar between grids described by thicknesses h_src and h_dst. !! h_dst must be dimensioned as a model array with GV%ke layers while h_src can !! have an arbitrary number of layers specified by nk_src. From 464046138500854a95a0e7f89ac1677e71c8462a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 24 Feb 2022 13:51:55 -0500 Subject: [PATCH 054/155] (*)Avoid negative thicknesses in mixed_layer_restrat Enforce a minimum thickness of 0.5*Angstrom in the mixed_layer_restrat routines. The streamfunctions in these routines attempt to limit the thicknesses to exceed Angstrom, but they can be less than this due to roundoff. The new limit prevents thicknesses from becoming negative when Angstrom is set to 0, but should not change any answers for test cases with positive values of Angstrom. Also added some comments describing variables and their units and simplified the OMP directives. Also corrected error messages in MOM_diabatic_aux.F90 to identify the file or module where these messages come from, and modified an error message in applyTracerBoundaryFluxesInOut so that it is written if the localized fault does not happen to occur on the root PE. All answers in the existing MOM6-examples regression suite are bitwise identical. --- .../lateral/MOM_mixed_layer_restrat.F90 | 85 ++++++++++--------- .../vertical/MOM_diabatic_aux.F90 | 12 +-- src/tracer/MOM_tracer_diabatic.F90 | 2 +- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 04982d7171..6176f4aa1d 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -156,15 +156,16 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a - ! layer. The vertical sum of a() through the pieces of + ! layer [nondim]. The vertical sum of a() through the pieces of ! the mixed layer must be 0. - real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD + real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD [nondim] real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: uDml_slow(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper @@ -172,21 +173,25 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales in the zonal and real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays ! for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 - real :: aFac, bFac ! Nondimensional ratios [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - real :: hAtVel, zpa, zpb, dh, res_scaling_fac + real :: aFac, bFac ! Nondimensional ratios [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: zpa ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: zpb ! Fractional position within the mixed layer of the interface below a layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions + real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions [nondim] ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) !PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) ) PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) * (1. + (5./21.)*(2.*z+1.)**2) ) @@ -198,6 +203,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & @@ -299,16 +306,11 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr,EOSdom, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & -!$OMP res_upscale, nz,MLD_fast,uDml_diag,vDml_diag) & -!$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP line_is_empty, keep_going,res_scaling_fac, & -!$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & -!$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) -!$OMP do + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP line_is_empty, keep_going,res_scaling_fac, & + !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & + !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) + !$OMP do do j=js-1,je+1 do i=is-1,ie+1 htot_fast(i,j) = 0.0 ; Rml_av_fast(i,j) = 0.0 @@ -359,7 +361,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) @@ -435,7 +437,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) @@ -510,12 +512,13 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -590,23 +593,23 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] - 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 :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux magnitudes (uDml & vDml) + ! to the realized flux in a layer [nondim]. The vertical sum of a() + ! through the pieces of the mixed layer must be 0. real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! in the zonal and meridional - ! directions [T ~> s], stored in 2-D + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales in the zonal and + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D ! arrays for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -619,6 +622,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 @@ -633,14 +637,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail,EOSdom, & -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP uDml_diag,vDml_diag,nkml) & -!$OMP private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP I2htot,z_topx2,hx2,a) & -!$OMP firstprivate(uDml,vDml) -!$OMP do + !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP I2htot,z_topx2,hx2,a) & + !$OMP firstprivate(uDml,vDml) + !$OMP do do j=js-1,je+1 do i=is-1,ie+1 htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 @@ -664,7 +664,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z @@ -711,7 +711,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z @@ -756,12 +756,13 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 13d25f06f5..6f1988c295 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -650,7 +650,7 @@ end subroutine set_pen_shortwave !> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & id_N2subML, id_MLDsq, dz_subML) type(ocean_grid_type), intent(in) :: G !< Grid type @@ -781,7 +781,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, end subroutine diagnoseMLDbyDensityDifference !> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! Author: Brandon Reichl ! Date: October 2, 2020 @@ -1377,7 +1377,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=',netHeat(i),netSalt(i),netMassInOut(i) write(0,*) 'applyBoundaryFluxesInOut(): dT,dS,dH=',dTemp,dSalt,dThickness write(0,*) 'applyBoundaryFluxesInOut(): h(n),h(n+1),k=',hOld,h2d(i,k),k - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Complete mass loss in column!") endif @@ -1392,7 +1392,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t write(0,*) 'applyBoundaryFluxesInOut(): netHeat,netSalt,netMassIn,netMassOut=',& netHeat(i),netSalt(i),netMassIn(i),netMassOut(i) - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass loss over land?") endif @@ -1526,13 +1526,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m - call MOM_error(WARNING, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) enddo if (numberOfGroundings - maxGroundings > 0) then write(mesg, '(i4)') numberOfGroundings - maxGroundings - call MOM_error(WARNING, "MOM_diabatic_driver:F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//& trim(mesg) // " groundings remaining") endif endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index c865e645ad..66adfb3695 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -635,7 +635,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim if (numberOfGroundings - maxGroundings > 0) then write(mesg, '(i4)') numberOfGroundings - maxGroundings call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& - trim(mesg) // " groundings remaining") + trim(mesg) // " groundings remaining", all_print=.true.) endif endif From efa503bd2753909530ec02e3a984f30d7fe58e7d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 8 Mar 2022 13:12:41 -0500 Subject: [PATCH 055/155] bugfix: static h_new shape remaining_transport_sum This patch redefines `h_new` to match the shape of a center-point rather than a v-face point. Dynamic memory builds would have been unaffected by this, and older GCC (~7.3.0) compilers appear to have not objected to the shape mismatch, but this raised an error in newer GCCs (~9.3.0). Since this redefines `h_new` from zero-based to 1-based indexing in the y-axis, answer changes are very possible. --- src/tracer/MOM_offline_main.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index d5b3f708a3..800523be2b 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -599,7 +599,7 @@ real function remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) intent(in ) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in ) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: h_new !< Layer thicknesses [H ~> m or kg m-2] ! Local variables From d5601696e9df88e87fcc793be68493935079b0f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Mar 2022 11:15:02 -0500 Subject: [PATCH 056/155] +Stop logging NEW_SPONGES Stop logging the deprecated run-time parameter NEW_SPONGES, and always log INTERPOLATE_SPONGE_TIME_SPACE as if NEW_SPONGES were not used. This commit will address MOM6 issue #46, which can be closed it is accepted. This will change the MOM_parameter_doc entries in some cases, but all answers are bitwise identical. --- src/diagnostics/MOM_obsolete_params.F90 | 3 ++ .../MOM_state_initialization.F90 | 39 ++++++++++++------- 2 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index dfadaa1da5..27c9b988ee 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -93,6 +93,9 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") + ! This parameter is on the to-do list to be obsoleted. + ! call obsolete_logical(param_file, "NEW_SPONGES", hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 8378644ea9..9b86c55be0 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1892,10 +1892,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t character(len=200) :: filename, inputdir ! Strings for file/path and path. logical :: use_ALE ! True if ALE is being used, False if in layered mode - logical :: time_space_interp_sponge ! True if using sponge data which - ! need to be interpolated from in both the horizontal dimension and in - ! time prior to vertical remapping. - + logical :: new_sponge_param ! The value of a deprecated parameter. + logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both + ! the horizontal dimension and in time prior to vertical remapping. 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 @@ -1948,20 +1947,34 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t "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, & + + !### NEW_SPONGES should be obsoleted properly, rather than merely deprecated, at which + ! point only the else branch of the new_sponge_param block would be retained. + call get_param(param_file, mdl, "NEW_SPONGES", new_sponge_param, & "Set True if using the newer sponging code which "//& "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=.false.) - if (time_space_interp_sponge) then - call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& + "of sponge restoring data.", default=.false., do_not_log=.true.) + if (new_sponge_param) then + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.true., do_not_log=.true.) + if (.not.time_space_interp_sponge) then + call MOM_error(FATAL, " initialize_sponges: NEW_SPONGES has been deprecated, "//& + "but is set to true inconsistently with INTERPOLATE_SPONGE_TIME_SPACE. "//& + "Remove the NEW_SPONGES input line.") + else + call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& "INTERPOLATE_SPONGE_TIME_SPACE = True.") + endif + call log_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.true.) + else + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.false.) endif - call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & - "Set True if using the newer sponging code which "//& - "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=time_space_interp_sponge) ! Read in sponge damping rate for tracers From 3042942603e6d81dc0350277ebc248ab2188d5ed Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sun, 13 Mar 2022 13:06:29 -0400 Subject: [PATCH 057/155] Fix nolibs build in CI pipeline - Enabling pipelines for SIS2 required making the MOM6_SRC macro mandatory. It was set in .gitlab-ci.yml for all targets except nolibs build. --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5e1da1c1f9..c22bfc4144 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -44,14 +44,14 @@ gnu:ocean-only-nolibs: tags: - ncrc4 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-oceanonly-nolibs + - make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-gnu-oceanonly-nolibs gnu:ice-ocean-nolibs: stage: builds tags: - ncrc4 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-iceocean-nolibs + - make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-gnu-iceocean-nolibs intel:repro: stage: builds From 3675c216975876b24d31353f560043d2eea58052 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Mar 2022 08:58:20 -0500 Subject: [PATCH 058/155] +Add Hybgen remapping options This commit adds the ability to specify three remapping options derived from Hycom's hybgen code. - Adds the new module MOM_hybgen_remap, which contains the new subroutines hybgen_plm_coefs, hybgen_ppm_coefs, and hybgen_weno_coefs - Adds code to handle PLM_HYBGEN, PPM_HYBGEN and WENO_HYBGEN as valid entries for specifying the ALE remapping schemes. Also added descriptions of units to some internal remapping variables. - Adds the optional argument PCM_cell to regridding_main, remapping_core_h, and remap_all_state_vars to specify layers that should use piecewise constant remapping, regardless of the overall remapping scheme, to follow the approach used in Hycom. ALE_main uses these new optional arguments, although until the Hybgen regridding code is added, they will always be set to false. - Makes 7 character strings longer in 5 files to accommodate the new remapping options. All answers are bitwise identical, but there are changes to some entries in the MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 19 +- src/ALE/MOM_hybgen_remap.F90 | 391 ++++++++++++++++++ src/ALE/MOM_regridding.F90 | 10 +- src/ALE/MOM_remapping.F90 | 112 +++-- src/core/MOM_open_boundary.F90 | 4 +- .../MOM_state_initialization.F90 | 2 +- .../MOM_tracer_initialization_from_Z.F90 | 2 +- src/ocean_data_assim/MOM_oda_incupd.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 19 +- .../vertical/MOM_CVMix_KPP.F90 | 4 +- 10 files changed, 515 insertions(+), 50 deletions(-) create mode 100644 src/ALE/MOM_hybgen_remap.F90 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 46669c20cb..d8eee55c14 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -380,6 +380,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] + logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) !< If true, PCM remapping should be used in a cell. integer :: nk, i, j, k, isc, iec, jsc, jec, ntr nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec @@ -405,7 +406,7 @@ 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. call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & - frac_shelf_h ) + frac_shelf_h, PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) @@ -419,7 +420,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) ! Remap all variables from old grid h onto new grid h_new call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, dzRegrid, u, v, & - CS%show_call_tree, dt ) + CS%show_call_tree, dt, PCM_cell=PCM_cell ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") @@ -776,7 +777,7 @@ end subroutine ALE_regrid_accelerated !! remap initial conditions to the model grid. It is also called during a !! time step to update the state. subroutine remap_all_state_vars(CS, G, GV, h_old, h_new, Reg, OBC, & - dzInterface, u, v, debug, dt ) + dzInterface, u, v, debug, dt, PCM_cell) type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -795,6 +796,8 @@ subroutine remap_all_state_vars(CS, G, GV, h_old, h_new, Reg, OBC, & optional, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] @@ -861,8 +864,14 @@ subroutine remap_all_state_vars(CS, G, GV, h_old, h_new, Reg, OBC, & ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & - h_neglect, h_neglect_edge) + if (present(PCM_cell)) then + PCM(:) = PCM_cell(i,j,:) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge, PCM_cell=PCM) + else + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge) + endif ! Intermediate steps for tendency of tracer concentration and tracer content. if (present(dt)) then diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 new file mode 100644 index 0000000000..539c992283 --- /dev/null +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -0,0 +1,391 @@ +!> This module contains the hybgen remapping routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_remap + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +contains + +!> Set up the coefficients for PLM remapping of a set of scalars +subroutine hybgen_plm_coefs(si, dpi, slope, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: si(nk,ns) !< The cell-averaged input scalar fields [A] + real, intent(in) :: dpi(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: slope(nk,ns) !< The PLM slope times cell width [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: piecewise linear across each input cell with +! monotonized central-difference limiter. +! +! van Leer, B., 1977, J. Comp. Phys., 23 276-299. +! +! 2) input arguments: +! si - initial scalar fields in pi-layer space +! dpi - initial layer thicknesses (dpi(k) = pi(k+1)-pi(k)) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! slope - coefficients for hybgen_plm_remap +! profile(y) = si+slope*(y-1), -0.5 <= y <= 0.5 +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: qcen ! A layer's thickness divided by the distance between the centers + ! of the adjacent cells, usually ~0.5, but always <= 1 [nondim] + real :: zbot, zcen, ztop ! Tracer slopes times the layer thickness [A] + integer :: i, k + + do i=1,ns + slope(1, i) = 0.0 + slope(nk,i) = 0.0 + enddo !i + do k= 2,nk-1 + if (dpi(k) <= thin) then !use PCM + do i=1,ns ; slope(k,i) = 0.0 ; enddo + else +! --- use qcen in place of 0.5 to allow for non-uniform grid + qcen = dpi(k) / (dpi(k)+0.5*(dpi(k-1)+dpi(k+1))) !dpi(k)>thin + do i=1,ns +! --- PLM (non-zero slope, but no new extrema) +! --- layer value is si-0.5*slope at top interface, +! --- and si+0.5*slope at bottom interface. +! +! --- monotonized central-difference limiter (van Leer, 1977, +! --- JCP 23 pp 276-299). For a discussion of PLM limiters, see +! --- Finite Volume Methods for Hyperbolic Problems by R.J. Leveque. + ztop = 2.0*(si(k, i)-si(k-1,i)) + zbot = 2.0*(si(k+1,i)-si(k, i)) + zcen = qcen*(si(k+1,i)-si(k-1,i)) + if (ztop*zbot > 0.0) then !ztop,zbot are the same sign + slope(k,i) = sign(min(abs(zcen),abs(zbot),abs(ztop)), zbot) + else + slope(k,i) = 0.0 !local extrema, so no slope + endif + enddo !i + endif !PCM:PLM + enddo !k + + if (present(PCM_lay)) then + do k=1,nk ; if (PCM_lay(k)) then + do i=1,ns ; slope(k,i) = 0.0 ; enddo + endif ; enddo + endif + +end subroutine hybgen_plm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The PPM interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic piecewise parabolic across each input cell +! +! Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the PPM reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell. + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k, i + + ! This PPM remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + do i=1,ns + !Compute average slopes: Colella, Eq. (1.8) + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then !use PCM + as(k) = 0.0 + else + slk = s(k, i)-s(k-1,i) + srk = s(k+1,i)-s(k, i) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif !PCM:PPM + enddo !k + as(nk) = 0. + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = s(1,i) ! 1st layer PCM + ar(1) = s(1,i) ! 1st layer PCM + al(2) = s(1,i) ! 1st layer PCM + do K=3,nk-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*s(k-1,i) + dp(k-1)*s(k,i)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k,i)-s(k-1,i)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(nk-1) = s(nk,i) ! last layer PCM + al(nk) = s(nk,i) ! last layer PCM + ar(nk) = s(nk,i) ! last layer PCM + !Impose monotonicity: Colella, Eq. (1.10) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1,i)-s(k,i))*(s(k,i)-s(k-1,i)) <= 0.)) then !local extremum + al(k) = s(k,i) + ar(k) = s(k,i) + else + da = ar(k)-al(k) + a6 = 6.0*s(k,i) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then !peak in right half of zone + al(k) = 3.0*s(k,i) - 2.0*ar(k) + elseif (da*a6 < -da*da) then !peak in left half of zone + ar(k) = 3.0*s(k,i) - 2.0*al(k) + endif + endif + enddo !k + !Set coefficients + do k=1,nk + edges(k,1,i) = al(k) + edges(k,2,i) = ar(k) + enddo !k + enddo !i + +end subroutine hybgen_ppm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The WENO interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic WENO-like alternative to PPM across each input cell +! a second order polynomial approximation of the profiles +! using a WENO reconciliation of the slopes to compute the +! interfacial values +! +! This scheme might have ben developed by Shchepetkin. A.F., personal communication. +! See also Engwirda, D., and M. Kelley, A WENO-type slope-limiter for a family of piecewise +! polynomial methods, arXive:1606.08188v1, 27 June 2016. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the WENO reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Laurent Debreu, Grenoble. +! Alan J. Wallcraft, Naval Research Laboratory, July 2008. +!----------------------------------------------------------------------- +! +! real, parameter :: dsmll=1.0e-8 ! This has units of [A2], and hence can not be a parameter. +! + real :: curv_cell ! An estimate of the tracer curvature centered on a cell times the grid + ! spacing [A H-1 ~> A m-1 or A kg m-2] + real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] + real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] + real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] + real :: ds2a, ds2b ! Squared tracer differences between a cell average and the edge values [A2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + real :: qdpkm(nk) ! Inverse of the sum of two adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: qdpkmkp(nk) ! Inverse of the sum of three adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: dpkm2kp(nk) ! Twice the distance between the centers of the layers two apart [H ~> m or kg m-2] + real :: zw(nk,2) ! Squared combinations of the differences between the the cell average tracer + ! concentrations and the left and right edges [A2] + real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim] + real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim] + real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A kg m-2] + real :: val_edge(nk+1) ! A weighted average edge concentration [A] + integer :: i, k + + min_ratio = 1.0e-8 + + ! The WENO remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk-1 + qdpkm( K) = 1.0 / (dp(k-1) + dp(k)) + qdpkmkp(k) = 1.0 / (dp(k-1) + dp(k) + dp(k+1)) + dpkm2kp(k) = dp(k-1) + 2.0*dp(k) + dp(k+1) + enddo !k + qdpkm(nk) = 1.0 / (dp(nk-1) + dp(nk)) + + do i=1,ns + do K=2,nk + slope_edge(K) = qdpkm(K) * (s(k,i)-s(k-1,i)) + enddo !k + k = 1 !PCM first layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + do k=2,nk-1 + if ((slope_edge(K)*slope_edge(K+1) < 0.0) .or. PCM_layer(k)) then !use PCM + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + else + seh1 = dp(k)*slope_edge(K+1) + seh2 = dp(k)*slope_edge(K) + q01 = dpkm2kp(k)*slope_edge(K+1) + q02 = dpkm2kp(k)*slope_edge(K) + if (abs(seh1) > abs(q02)) then + seh1 = q02 + endif + if (abs(seh2) > abs(q01)) then + seh2 = q01 + endif + curv_cell = (seh1 - seh2) * qdpkmkp(k) + q001 = seh1 - curv_cell*dp(k+1) + q002 = seh2 + curv_cell*dp(k-1) + ! q001 = (seh1 * (dp(k-1) + dp(k)) + seh2 * dp(k+1)) * qdpkmkp(k) + ! q002 = (seh2 * (dp(k+1) + dp(k)) + seh1 * dp(k-1)) * qdpkmkp(k) + + edges(k,2,i) = s(k,i) + q001 + edges(k,1,i) = s(k,i) - q002 + zw(k,1) = (2.0*q001 - q002)**2 + zw(k,2) = (2.0*q002 - q001)**2 + endif !PCM:WENO + enddo !k + k = nk !PCM last layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k, 1) = 0.0 + zw(k, 2) = 0.0 + + do k=2,nk + ! This was the original code based on that in Hycom, but because zw has + ! dimensions of [A2], it can not use a constant (hard coded) value of dsmll. + ! ds2a = max(zw(k-1,2), dsmll) + ! ds2b = max(zw(k, 1), dsmll) + ! val_edge(K) = (ds2b*edges(k-1,2,i)+ds2a*edges(k,1,i)) / (ds2b+ds2a) + ! Use a weighted average of the two layers' estimated edge values as the actual edge value. + if (zw(k,1) + zw(k-1,2) <= 0.0) then + wt1 = 0.5 + elseif (zw(k,1) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = min_ratio + elseif (zw(k-1,2) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = (1.0 - min_ratio) + else + wt1 = zw(k,1) / (zw(k,1) + zw(k-1,2)) + endif + val_edge(k) = wt1*edges(k-1,2,i) + (1.0-wt1)*edges(k,1,i) + enddo !k + val_edge( 1) = 2.0*s( 1,i)-val_edge( 2) !not used? + val_edge(nk+1) = 2.0*s(nk,i)-val_edge(nk) !not used? + + do k=2,nk-1 + if (.not.PCM_layer(k)) then !don't use PCM + q01 = val_edge(K+1) - s(k,i) + q02 = s(k,i) - val_edge(K) + if (q01*q02 < 0.0) then + q01 = 0.0 + q02 = 0.0 + elseif (abs(q01) > abs(2.0*q02)) then + q01 = 2.0*q02 + elseif (abs(q02) > abs(2.0*q01)) then + q02 = 2.0*q01 + endif + edges(k,1,i) = s(k,i) - q02 + edges(k,2,i) = s(k,i) + q01 + endif ! PCM:WENO + enddo !k + enddo !i + +end subroutine hybgen_weno_coefs + +end module MOM_hybgen_remap diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index dafd165245..008475b16d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -753,7 +753,8 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, conv_adjust) +subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, & + conv_adjust, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between ! the old grid and the new grid. The creation of the new grid can be based @@ -783,15 +784,16 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true + ! Local variables real :: trickGnuCompiler - logical :: use_ice_shelf logical :: do_convective_adjustment do_convective_adjustment = .true. if (present(conv_adjust)) do_convective_adjustment = conv_adjust - - use_ice_shelf = present(frac_shelf_h) + if (present(PCM_cell)) PCM_cell(:,:,:) = .false. select case ( CS%regridding_scheme ) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 1b3c5884de..82087eea24 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -13,12 +13,12 @@ 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 MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + use MOM_io, only : stdout, stderr implicit none ; private -#include - !> Container for remapping parameters type, public :: remapping_CS private @@ -46,11 +46,14 @@ module MOM_remapping ! The following are private parameter constants integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme -integer, parameter :: REMAPPING_PLM = 1 !< O(h^2) remapping scheme -integer, parameter :: REMAPPING_PPM_H4 = 2 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PPM_IH4 = 3 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PQM_IH4IH3 = 4 !< O(h^4) remapping scheme -integer, parameter :: REMAPPING_PQM_IH6IH5 = 5 !< O(h^5) remapping scheme +integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_WENO_HYBGEN= 7 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PQM_IH4IH3 = 8 !< O(h^4) remapping scheme +integer, parameter :: REMAPPING_PQM_IH6IH5 = 9 !< O(h^5) remapping scheme integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method @@ -60,11 +63,14 @@ module MOM_remapping character(len=40) :: mdl = "MOM_remapping" !< This module's name. !> Documentation for external callers -character(len=256), public :: remappingSchemesDoc = & +character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& "PLM (2nd-order accurate)\n"//& + "PLM_HYBGEN (2nd-order accurate)\n"//& "PPM_H4 (3rd-order accurate)\n"//& "PPM_IH4 (3rd-order accurate)\n"//& + "PPM_HYBGEN (3rd-order accurate)\n"//& + "WENO_HYBGEN (3rd-order accurate)\n"//& "PQM_IH4IH3 (4th-order accurate)\n"//& "PQM_IH6IH5 (5th-order accurate)\n" character(len=3), public :: remappingDefaultScheme = "PLM" !< Default remapping method @@ -185,41 +191,50 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) end function isPosSumErrSignificant !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid - real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] + real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h0. + !! in the same units as h0 [H] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value - !! calculations in the same units as h0. + !! calculations in the same units as h0 [H] + logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for + !! cells in the source grid where this is true. + ! Local variables integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial + real :: edges(n0,2) ! Interpolation edge values [A] + real :: slope(n0) ! Interpolation slopes per cell width [A] + real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] + real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] + real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] + real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] + real :: uh_err ! Difference in the total amounts on the two grids [H A] + real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: k - real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err - real :: hNeglect, hNeglect_edge hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - hNeglect, hNeglect_edge ) + hNeglect, hNeglect_edge, PCM_cell ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) - + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + CS%force_bounds_in_subcell, u1, uh_err ) if (CS%check_remapping) then ! Check errors and bounds @@ -306,7 +321,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed endif enddo call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell,u1, uh_err ) + CS%force_bounds_in_subcell, u1, uh_err ) ! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) ! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) @@ -353,7 +368,7 @@ end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & - h_neglect_edge ) + h_neglect_edge, PCM_cell ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid @@ -369,10 +384,14 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value !! calculations in the same units as h0. + logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for + !! cells from the source grid where this is true. + ! Local variables integer :: local_remapping_scheme integer :: remapping_scheme !< Remapping scheme logical :: boundary_extrapolation !< Extrapolate at boundaries if true + integer :: k, n ! Reset polynomial ppoly_r_E(:,:) = 0.0 @@ -398,6 +417,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) endif iMethod = INTEGRATION_PLM + case ( REMAPPING_PLM_HYBGEN ) + call hybgen_PLM_coefs(u0, h0, ppoly_r_coefs(:,2), n0, 1, h_neglect) + do k=1,n0 + ppoly_r_E(k,1) = u0(k) - 0.5 * ppoly_r_coefs(k,2) ! Left edge value of cell k + ppoly_r_E(k,2) = u0(k) + 0.5 * ppoly_r_coefs(k,2) ! Right edge value of cell k + ppoly_r_coefs(k,1) = ppoly_r_E(k,1) + enddo + if ( CS%boundary_extrapolation ) & + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) @@ -412,6 +441,18 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_HYBGEN ) + call hybgen_PPM_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=.false. ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM + case ( REMAPPING_WENO_HYBGEN ) + call hybgen_weno_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=.false. ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) @@ -437,6 +478,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & 'The selected remapping method is invalid' ) end select + if (present(PCM_cell)) then + ! Change the coefficients to those for the piecewise constant method in indicated cells. + do k=1,n0 ; if (PCM_cell(k)) then + ppoly_r_coefs(k,1) = u0(k) + ppoly_r_E(k,1:2) = u0(k) + ppoly_r_S(k,1:2) = 0.0 + do n=2,CS%degree+1 ; ppoly_r_coefs(k,n) = 0.0 ; enddo + endif ; enddo + endif + end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds @@ -1580,12 +1631,21 @@ subroutine setReconstructionType(string,CS) case ("PLM") CS%remapping_scheme = REMAPPING_PLM degree = 1 + case ("PLM_HYBGEN") + CS%remapping_scheme = REMAPPING_PLM_HYBGEN + degree = 1 case ("PPM_H4") CS%remapping_scheme = REMAPPING_PPM_H4 degree = 2 case ("PPM_IH4") CS%remapping_scheme = REMAPPING_PPM_IH4 degree = 2 + case ("PPM_HYBGEN") + CS%remapping_scheme = REMAPPING_PPM_HYBGEN + degree = 2 + case ("WENO_HYBGEN") + CS%remapping_scheme = REMAPPING_WENO_HYBGEN + degree = 2 case ("PQM_IH4IH3") CS%remapping_scheme = REMAPPING_PQM_IH4IH3 degree = 4 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 41ba70f152..5fc168f5a4 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -360,8 +360,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=128) :: inputdir logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - character(len=32) :: remappingScheme -! This include declares and sets the variable "version". + character(len=64) :: remappingScheme + ! This include declares and sets the variable "version". # include "version_variable.h" allocate(OBC) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 8378644ea9..45020c86f5 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2450,7 +2450,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! extrapolating the densities at the bottom of unstable profiles ! from data when finding the initial interface locations in ! layered mode from a dataset of T and S. - character(len=10) :: remappingScheme + character(len=64) :: remappingScheme real :: tempAvg, saltAvg integer :: nPoints, ans integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 8a67d71fe2..9b6800524b 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -58,7 +58,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ character(len=200) :: mesg real :: convert integer :: recnum - character(len=10) :: remapScheme + character(len=64) :: remapScheme logical :: homog,useALE ! This include declares and sets the variable "version". diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index ab3621296f..af9534e943 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -142,7 +142,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res real :: nhours_incupd, dt, dt_therm type(vardesc) :: vd character(len=256) :: mesg - character(len=10) :: remapScheme + character(len=64) :: remapScheme if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 472ee21e36..6b89a86b30 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -163,16 +163,18 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! time at v-points [T-1 ~> s-1]. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables 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_v !< inverse of the restoring time at v points [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme + if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & "control structure.") @@ -422,17 +424,18 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest 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" + ! Local variables 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_v !< inverse of the restoring time at v points [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d12d850a73..f7378bb37b 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -77,8 +77,8 @@ module MOM_CVMix_KPP real :: cs2 !< Parameter for multiplying by non-local term ! This is active for NLT_SHAPE_CUBIC_LMD only logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. - character(len=10) :: interpType !< Type of interpolation to compute bulk Richardson number - character(len=10) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number + character(len=32) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity From 5a8590b03b794b240a15692bdc79075c6b6a4be8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Mar 2022 18:16:33 -0500 Subject: [PATCH 059/155] +Add Laplacian diffusion of interface heights Added the capability to do Laplacian diffusion of interface heights without regard to the density of layers. This is accomplished by the new internal subroutine add_interface_KH, and is controlled by the new runtime parameters KH_ETA_CONST and KH_ETA_VEL_SCALE. The new interface diffusivities are subject to CFL bounding when combined with the previous isopycnal slope diffusivities, with the two diffusivities reduced proportionately when the CFL limits are exceeded. Also simplified many openMP directives in MOM_thickness_diffuse.F90, and fixed a number of spelling errors or other problems in comments, including adding units to some variables. By default, all answers are bitwise identical, although there are new runtime parameters a new internal subroutine. --- .../lateral/MOM_thickness_diffuse.F90 | 438 +++++++++++------- 1 file changed, 260 insertions(+), 178 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8303d30621..55e4593dc4 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -36,11 +36,14 @@ module MOM_thickness_diffuse !> Control structure for thickness diffusion type, public :: thickness_diffuse_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Khth !< Background interface depth diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] - real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion + real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion [nondim] real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max + real :: Kh_eta_bg !< Background interface height diffusivity [L2 T-1 ~> m2 s-1] + real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give + !! the interface height diffusivity [L T-1 ~> m s-1] real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. real :: kappa_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. @@ -52,7 +55,7 @@ module MOM_thickness_diffuse !! Ferrari et al., 2010, streamfunction formulation [nondim]. real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, !! streamfunction formulation [L T-1 ~> m s-1]. - real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, + real :: N2_floor !< A floor for squared buoyancy frequency in the Ferrari et al., 2010, !! streamfunction formulation [T-2 ~> s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height !! diffusivities to horizontally smooth jagged layers. @@ -67,7 +70,7 @@ module MOM_thickness_diffuse logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha!< The nondimensional coefficient governing the efficiency of - !! the GEOMETRIC thickness difussion [nondim] + !! the GEOMETRIC thickness diffusion [nondim] real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness !! diffusivity [T-1 ~> s-1]. logical :: MEKE_GEOM_answers_2018 !< If true, use expressions in the MEKE_GEOMETRIC calculation @@ -80,15 +83,18 @@ module MOM_thickness_diffuse !! top-level work tendency on the top layer. real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean !! temperature gradient in the deterministic part of the Stanley parameterization. - !! Negative values disable the scheme." [nondim] + !! Negative values disable the scheme. [nondim] type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, allocatable :: GMwork(:,:) !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] real, allocatable :: diagSlopeY(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] - real, allocatable :: KH_u_GME(:,:,:) !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_v_GME(:,:,:) !< interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_u(:,:) !< Interface height diffusivities at u points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_v(:,:) !< Interface height diffusivities in v points [L2 T-1 ~> m2 s-1] + + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -121,45 +127,45 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion ! Local variables - real :: e(SZI_(G), SZJ_(G),SZK_(GV)+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_(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 :: 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_(GV)+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_(GV)+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_(GV)) :: & + 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)) :: & + real, dimension(SZIB_(G),SZJ_(G)) :: & KH_u_CFL ! The maximum stable interface height diffusivity at u grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G)) :: & KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJ_(G)) :: & + real, dimension(SZI_(G),SZJ_(G)) :: & htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] - real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) - real :: Khth_Loc_v(SZI_(G), SZJB_(G)) - real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) + real :: Khth_Loc_v(SZI_(G),SZJB_(G)) + real :: Khth_Loc(SZIB_(G),SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz - real :: hu(SZI_(G), SZJ_(G)) ! u-thickness [H ~> m or kg m-2] - real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] - real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: hu(SZI_(G),SZJ_(G)) ! u-thickness [H ~> m or kg m-2] + real :: hv(SZI_(G),SZJ_(G)) ! v-thickness [H ~> m or kg m-2] + real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: KH_v_lay(SZI_(G),SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -192,12 +198,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt,G,CS) + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt,G,CS) + !$OMP parallel do default(shared) do j=js-1,je ; do I=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) @@ -207,19 +213,15 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp call find_eta(h, tv, G, GV, US, e, halo_size=1) ! Set the diffusivities. -!$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & -!$OMP MEKE,Resoln_scaled,KH_u,G,use_QG_Leith,use_Visbeck,& -!$OMP KH_u_CFL,nz,Khth_Loc,KH_v,KH_v_CFL,int_slope_u, & -!$OMP int_slope_v,khth_use_ebt_struct, Depth_scaled, & -!$OMP Khth_loc_v) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = CS%Khth enddo ; enddo if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + & CS%KHTH_Slope_Cff*VarMix%L2u(I,j) * VarMix%SN_u(I,j) @@ -229,7 +231,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & @@ -243,42 +245,42 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do 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 + !$OMP do 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 + !$OMP do 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 + !$OMP do 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 + !$OMP do 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 if (khth_use_ebt_struct) then -!$OMP do + !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) enddo ; enddo ; enddo else -!$OMP do + !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie KH_u(I,j,K) = KH_u(I,j,1) enddo ; enddo ; enddo @@ -286,7 +288,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do j=js,je ; do I=is-1,ie KH_u(I,j,k) = VarMix%KH_u_QG(I,j,k) enddo ; enddo ; enddo @@ -294,20 +296,20 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do j=js,je ; do I=is-1,ie CS%KH_u_GME(I,j,k) = KH_u(I,j,k) enddo ; enddo ; enddo endif -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = CS%Khth enddo ; enddo if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) enddo ; enddo @@ -315,7 +317,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & @@ -329,45 +331,45 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do 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 if (Depth_scaled) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Depth_fn_v(i,J) enddo ; enddo endif if (CS%Khth_Max > 0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, min(Khth_loc_v(i,J), CS%Khth_Max)) enddo ; enddo else -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, Khth_loc_v(i,J)) enddo ; enddo endif if (CS%max_Khth_CFL > 0.0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc_v(i,J)) enddo ; enddo endif if (khth_use_ebt_struct) then -!$OMP do + !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) enddo ; enddo ; enddo else -!$OMP do + !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie KH_v(i,J,K) = KH_v(i,J,1) enddo ; enddo ; enddo @@ -375,7 +377,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do J=js-1,je ; do i=is,ie KH_v(i,J,k) = VarMix%KH_v_QG(i,J,k) enddo ; enddo ; enddo @@ -383,7 +385,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do J=js-1,je ; do i=is,ie CS%KH_v_GME(i,J,k) = KH_v(i,J,k) enddo ; enddo ; enddo @@ -414,17 +416,21 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP do + !$OMP do do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP do + !$OMP do do K=1,nz+1 ; do J=js-1,je ; do i=is,ie ; int_slope_v(i,J,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel if (CS%detangle_interfaces) then call 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) endif + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + call add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, int_slope_u, int_slope_v) + endif + if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) @@ -452,7 +458,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (VarMix%use_variable_mixing) then if (allocated(MEKE%Rd_dx_h) .and. allocated(VarMix%Rd_dx_h)) then -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,VarMix) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Rd_dx_h(i,j) = VarMix%Rd_dx_h(i,j) enddo ; enddo @@ -469,11 +475,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%id_KH_u1 > 0) call post_data(CS%id_KH_u1, KH_u(:,:,1), CS%diag) if (CS%id_KH_v1 > 0) call post_data(CS%id_KH_v1, KH_v(:,:,1), CS%diag) - ! Diagnose diffusivity at T-cell point. Do simple average, rather than - ! thickness-weighted average, in order that KH_t is depth-independent - ! in the case where KH_u and KH_v are depth independent. Otherwise, - ! if use thickness weighted average, the variations of thickness with - ! depth will place a spurious depth dependence to the diagnosed KH_t. + ! Diagnose diffusivity at T-cell point. Do a simple average, rather than a + ! thickness-weighted average, so that KH_t is depth-independent when KH_u and KH_v + ! are depth independent. If a thickness-weighted average were used, the variations + ! of thickness could give a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0 .or. CS%Use_KH_in_MEKE) then do k=1,nz ! thicknesses across u and v faces, converted to 0/1 mask @@ -523,7 +528,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif - !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt,vhtr,CDp,vhD,h,G,GV) + !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=is-1,ie uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt @@ -576,7 +581,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! [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), intent(inout) :: MEKE !< MEKE fields + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from @@ -588,9 +593,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - T, & ! The temperature (or density) [degC], with the values in + 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. @@ -598,28 +604,28 @@ 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_(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_(GV)+1) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] + hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at v-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] + hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at u-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + 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)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] - real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ignored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] - real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. @@ -628,8 +634,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v, & ! Temperature on the interface at the v-point [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. - real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] + real :: Work_u(SZIB_(G),SZJ_(G)) ! The work being done by the thickness + real :: Work_v(SZI_(G),SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. @@ -639,15 +645,16 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: drdi_u(SZIB_(G),SZK_(GV)) ! Copy of drdi at u-points [R ~> kg m-3]. - real :: drdj_v(SZI_(G), SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. + 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]. - real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m] + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. @@ -659,14 +666,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! streamfunction [Z L2 T-1 ~> m3 s-1]. real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. - 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 :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] + real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that ! the units are different from other Sfn vars). real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. - real :: Slope ! The slope of density surfaces, calculated in a way - ! that is always between -1 and 1, nondimensional. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. real :: h_neglect ! A thickness that is so small it is usually lost @@ -676,22 +683,27 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! in roundoff and can be neglected [Z ~> m]. real :: G_scale ! The gravitational acceleration times a unit conversion ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: Tl(5) ! copy and T in local stencil [degC] + real :: Tl(5) ! copy of T in local stencil [degC] real :: mn_T ! mean of T in local stencil [degC] - real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC2] real :: hl(5) ! Copy of local stencil of H [H ~> m] real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tsgs2 ! Sub-grid temperature variance [degC2] - - 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 + real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [degC2] + + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of ! state calculations at u-points. @@ -735,12 +747,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & -!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & -!$OMP private(hl,r_sm_H,Tl,mn_T,mn_T2) + !$OMP parallel default(shared) private(hl,r_sm_H,Tl,mn_T,mn_T2) ! Find the maximum and minimum permitted streamfunction. -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 h_avail_rsum(i,j,1) = 0.0 pres(i,j,1) = 0.0 @@ -752,7 +761,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo if (use_Stanley) then -!$OMP do + !$OMP do do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 !! SGS variance in i-direction [degC2] !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & @@ -786,7 +795,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif -!$OMP do + !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) @@ -796,34 +805,36 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV pres(i,j,K+1) = pres(i,j,K) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,k) enddo ; enddo enddo -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie uhtot(I,j) = 0.0 ; Work_u(I,j) = 0.0 - diag_sfn_x(I,j,1) = 0.0 ; diag_sfn_unlim_x(I,j,1) = 0.0 - diag_sfn_x(I,j,nz+1) = 0.0 ; diag_sfn_unlim_x(I,j,nz+1) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie vhtot(i,J) = 0.0 ; Work_v(i,J) = 0.0 - diag_sfn_y(i,J,1) = 0.0 ; diag_sfn_unlim_y(i,J,1) = 0.0 - diag_sfn_y(i,J,nz+1) = 0.0 ; diag_sfn_unlim_y(i,J,nz+1) = 0.0 enddo ; enddo -!$OMP end parallel - - EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & -!$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & -!$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & -!$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & -!$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & -!$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_u,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & -!$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + !$OMP end parallel + + if (CS%id_sfn_x > 0) then ; diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_y > 0) then ; diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_x > 0) then ; diag_sfn_unlim_x(:,:,1) = 0.0 ; diag_sfn_unlim_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_y > 0) then ; diag_sfn_unlim_y(:,:,1) = 0.0 ; diag_sfn_unlim_y(:,:,nz+1) = 0.0 ; endif + + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & + !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & + !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & + !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_u,scrap, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & + !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do j=js,je do I=is-1,ie ; hN2_u(I,1) = 0. ; hN2_u(I,nz+1) = 0. ; enddo do K=nz,2,-1 @@ -1064,7 +1075,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. Work_u(I,j) = Work_u(I,j) + G_scale * & @@ -1077,21 +1088,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of k-loop enddo ! end of j-loop - ! Calculate the meridional fluxes and gradients. - EOSdom_v(:) = EOS_domain(G%HI) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & -!$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & -!$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & -!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & -!$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & -!$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_v,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & -!$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + ! Calculate the meridional fluxes and gradients. + EOSdom_v(:) = EOS_domain(G%HI) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & + !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & + !$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & + !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_v,scrap, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & + !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do J=js-1,je do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then @@ -1329,7 +1341,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. Work_v(i,J) = Work_v(i,J) + G_scale * & @@ -1442,10 +1454,12 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables + real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] + real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] + real :: b_denom ! A term in the denominator of beta [L2 Z-1 T-2 ~> m s-2] + real :: beta ! The normalization for the pivot [Z T2 L-2 ~> s2 m-1] integer :: k - real :: b_denom, beta, d1, c1(nk) - sfn(1) = 0. b_denom = hN2(2) + c2_h(1) beta = 1.0 / ( b_denom + c2_h(2) ) @@ -1466,6 +1480,48 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver +!> Add a diffusivity that acts on the interface heights, regardless of the densities +subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_slope_u, int_slope_v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness diffusion + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + !! 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] + 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 + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do k=1,nz+1 ; do j=js,je ; do I=is-1,ie ; if (CS%Kh_eta_u(I,j) > 0.0) then + int_slope_u(I,j,K) = (int_slope_u(I,j,K)*Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) / & + (Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) + Kh_u(I,j,K) = min(Kh_u(I,j,K) + CS%Kh_eta_u(I,j), Kh_u_CFL(I,j)) + endif ; enddo ; enddo ; enddo + + do k=1,nz+1 ; do J=js-1,je ; do i=is,ie ; if (CS%Kh_eta_v(i,J) > 0.0) then + int_slope_v(i,J,K) = (int_slope_v(i,J,K)*Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) / & + (Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) + Kh_v(i,J,K) = min(Kh_v(i,J,K) + CS%Kh_eta_v(i,J), Kh_v_CFL(i,J)) + endif ; enddo ; enddo ; enddo + +end subroutine add_interface_Kh + !> 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) @@ -1510,7 +1566,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! with the thinner modified near the boundaries to mask out ! thickness variations due to topography, etc. real :: jag_Rat ! The nondimensional jaggedness ratio for a layer, going - ! from 0 (smooth) to 1 (jagged). This is the difference + ! from 0 (smooth) to 1 (jagged) [nondim]. This is the difference ! between the arithmetic and harmonic mean thicknesses ! normalized by the arithmetic mean thickness. real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged @@ -1527,20 +1583,22 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! and the ratio of the face length to the adjacent cell ! areas for comparability with the diffusivities [L Z T-1 ~> m2 s-1]. real :: adH ! The absolute value of dH [L Z T-1 ~> m2 s-1]. - real :: sign ! 1 or -1, with the same sign as the layer thickness gradient. + real :: sign ! 1 or -1, with the same sign as the layer thickness gradient [nondim]. real :: sl_K ! The sign-corrected slope of the interface above [Z L-1 ~> nondim]. real :: sl_Kp1 ! The sign-corrected slope of the interface below [Z L-1 ~> nondim]. real :: I_sl_K ! The (limited) inverse of sl_K [L Z-1 ~> nondim]. real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1 [L Z-1 ~> nondim]. real :: I_4t ! A quarter of a flux scaling factor divided by ! the damping timescale [T-1 ~> s-1]. - real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1. - real :: denom, I_denom ! A denominator and its inverse, various units. + real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1 [nondim] + real :: Idx_eff ! The effective inverse x-grid spacing at a u-point [L-1 ~> m-1] + real :: Idy_eff ! The effective inverse y-grid spacing at a v-point [L-1 ~> m-1] + real :: slope_sq ! The sum of the squared slopes above and below a layer [Z2 L-2 ~> nondim] real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. - real :: wt1, wt2 ! Nondimensional weights. + real :: wt1, wt2 ! Nondimensional weights [nondim]. ! Variables used only in testing code. - ! real, dimension(SZK_(GV)) :: uh_here - ! real, dimension(SZK_(GV)+1) :: Sfn + ! real, dimension(SZK_(GV)) :: uh_here ! The transport in a layer [Z L2 T-1 ~> m3 s-1] + ! real, dimension(SZK_(GV)+1) :: Sfn ! The streamfunction at an interface [Z L T-1 ~> m2 s-1] real :: dKh ! An increment in the diffusivity [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & @@ -1567,7 +1625,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV Kh_max_p , & ! See above [nondim]. Kh0_max_p ! See above [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G)) :: & - Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1].. + Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1] 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 @@ -1662,49 +1720,49 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV do k=k_top,nz ; do i=ish,ie ; if (do_i(i)) then if (n==1) then ! This is a u-column. dH = 0.0 - denom = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) + Idx_eff = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) ! This expression uses differences in e in place of h for better ! consistency with the slopes. - if (denom > 0.0) & + if (Idx_eff > 0.0) & dH = I_4t * ((e(i+1,j,K) - e(i+1,j,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idx_eff + ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / Idx_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) sl_Kp1 = sign * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) - ! Add the incremental diffusivites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_u(I,j,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_u(I,j,k) else ! This is a v-column. dH = 0.0 - denom = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) - if (denom > 0.0) & + Idy_eff = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) + if (Idy_eff > 0.0) & dH = I_4t * ((e(i,j+1,K) - e(i,j+1,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idy_eff + ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / Idy_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) sl_Kp1 = sign * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) - ! Add the incremental diffusviites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_v(i,J,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_v(i,J,k) @@ -1784,7 +1842,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) - ! Increase the diffusivies to satisfy the min constraints. + ! Increase the diffusivities to satisfy the min constraints. ! All non-zero min constraints on one diffusivity are max constraints on another. do K=k_top+1,nz ; do i=ish,ie ; if (do_i(i)) then Kh(I,K) = max(Kh_bg(I,K), Kh_detangle(I,K), & @@ -1892,14 +1950,17 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: grid_sp ! The local grid spacing [L ~> m] real :: omega ! The Earth's rotation rate [T-1 ~> s-1] - real :: strat_floor ! A floor for Brunt-Vasaila frequency in the Ferrari et al. 2010, + real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, ! streamfunction formulation, expressed as a fraction of planetary ! rotation [nondim]. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + integer :: i, j CS%initialized = .true. CS%diag => diag @@ -1929,9 +1990,30 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "much smaller numbers (e.g. 0.1) seem to work better for "//& "ALE-based models.", units = "nondimensional", default=0.8) -! call get_param(param_file, mdl, "USE_QG_LEITH_GM", CS%QG_Leith_GM, & -! "If true, use the QG Leith viscosity as the GM coefficient.", & -! default=.false.) + call get_param(param_file, mdl, "KH_ETA_CONST", CS%Kh_eta_bg, & + "The background horizontal diffusivity of the interface heights (without "//& + "considering the layer density structure). If diffusive CFL limits are "//& + "encountered, the diffusivities of the isopycnals and the interfaces heights "//& + "are scaled back proportionately.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KH_ETA_VEL_SCALE", CS%Kh_eta_vel, & + "A velocity scale that is multiplied by the grid spacing to give a contribution "//& + "to the horizontal diffusivity of the interface heights (without considering "//& + "the layer density structure).", & + default=0.0, units="m s-1", scale=US%m_to_L*US%T_to_s) + + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + allocate(CS%Kh_eta_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.) + allocate(CS%Kh_eta_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.) + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / (G%dxCu(I,j)**2 + G%dyCu(I,j)**2)) + CS%Kh_eta_u(I,j) = G%mask2dCu(I,j) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / (G%dxCv(i,J)**2 + G%dyCv(i,J)**2)) + CS%Kh_eta_v(i,J) = G%mask2dCv(i,J) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + endif if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & @@ -2171,12 +2253,12 @@ end subroutine thickness_diffuse_end !! \f[ !! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) !! \f] -!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the square root of Brunt-Vaisala frequency, +!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the Brunt-Vaisala frequency, !! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and !! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, !! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module !! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope -!! times the Brunt-Vaisala frequency prescribed by Visbeck et al., 1996. +!! times the buoyancy frequency prescribed by Visbeck et al., 1996. !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper !! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). @@ -2220,7 +2302,7 @@ end subroutine thickness_diffuse_end !! A boundary-value problem for the parameterized mesoscale eddy transport. !! Ocean Modelling, 32, 143-156. http://doi.org/10.1016/j.ocemod.2010.01.004 !! -!! Viscbeck, M., J.C. Marshall, H. Jones, 1996: +!! Visbeck, M., J.C. Marshall, H. Jones, 1996: !! Dynamics of isolated convective regions in the ocean. J. Phys. Oceangr., 26, 1721-1734. !! http://dx.doi.org/10.1175/1520-0485(1996)026%3C1721:DOICRI%3E2.0.CO;2 From 14a28f4775297b7a9c3c1fd7627e85d029cea989 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 11 Mar 2022 10:54:15 -0500 Subject: [PATCH 060/155] Avoid copying the tracer registry in advect_tracer This change avoids an unnecessary copy of the tracer registry in advect_tracer(). This should be more efficient, and it should facilitate the development of improved tracer budget diagnostic capabilities. It also adds comments describing a few internal variables and their units. All answers and output are bitwise identical. --- src/tracer/MOM_tracer_advect.F90 | 68 +++++++++++++++----------------- 1 file changed, 32 insertions(+), 36 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e2c669fcc7..79fd4f3cbf 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -83,7 +83,6 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first optional, intent(out) :: vhr_out !< Remaining accumulated volume or mass fluxes !! through the meridional faces [H L2 ~> m3 or kg] - type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers 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_(GV)) :: & @@ -127,7 +126,6 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 ntr = Reg%ntr - do m=1,ntr ; Tr(m) = Reg%Tr(m) ; enddo Idt = 1.0 / dt max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 @@ -138,7 +136,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) do m=1,ntr - call create_group_pass(CS%pass_uhr_vhr_t_hprev, Tr(m)%t, G%Domain) + call create_group_pass(CS%pass_uhr_vhr_t_hprev, Reg%Tr(m)%t, G%Domain) enddo call cpu_clock_end(id_clock_pass) @@ -188,27 +186,11 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! initialize diagnostic fluxes and tendencies !$OMP do do m=1,ntr - if (associated(Tr(m)%ad_x)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%ad_x(I,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad_y)) then - do k=1,nz ; do J=jsd,jed ; do i=isd,ied - Tr(m)%ad_y(i,J,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%advection_xy)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%advection_xy(i,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_x)) then - do j=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_x(I,j) = 0.0 ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_y)) then - do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo - endif + if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 enddo !$OMP end parallel @@ -265,14 +247,14 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) ! Update domore_k(k) for the next iteration @@ -287,14 +269,14 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) ! Update domore_k(k) for the next iteration @@ -390,13 +372,20 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: tiny_h ! The smallest numerically invertible thickness [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 :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer concentration in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. logical :: do_any_i + logical :: usePLMslope integer :: i, j, m, n, i_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - 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_(GV)) :: domore_u_initial ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x @@ -547,7 +536,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then @@ -754,14 +743,21 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real :: tiny_h ! The smallest numerically invertible thickness [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 :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer average in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. logical :: do_any_i + logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - real :: fac1,v_L_in,v_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() - logical :: usePLMslope usePLMslope = .not. (usePPM .and. useHuynh) ! stencil for calculating slope values @@ -919,7 +915,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then From a002923ae525894ceaa00de8818faf046d35ec46 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Mar 2022 06:20:43 -0500 Subject: [PATCH 061/155] (*)Fix rescaling in RGC_initialize_sponges Corrected the dimensional rescaling in RGC_initialize_sponges(). Also added comments documenting the units of all the real values in this module. Only dimensional rescaling factors are changed, and the code should now reproduce for different values of dimensional rescaling factors. All answers in the MOM6-examples regression suite are bitwise identical. --- src/user/RGC_initialization.F90 | 45 +++++++++++++++------------------ 1 file changed, 20 insertions(+), 25 deletions(-) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index b8eae3c704..a3e22de81a 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -61,29 +61,28 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C target, intent(in) :: v !< Array with the v velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: PF !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode - type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values. + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure -! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp - real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temperature [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [ppt] 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_(GV)) ! A temporary array for thickness at h points + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points [H ~> m or kg m-2] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] - real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [Z ~> 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 - real :: lenlat, lenlon, lensponge + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: dummy1 ! The position relative to the sponge width [nondim] + real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) + real :: lenlat, lenlon ! The sizes of the domain [km] + real :: lensponge ! The width of the sponge [km] character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var @@ -95,8 +94,9 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB + ! The variable min_thickness is unused, and can probably be eliminated. call get_param(PF, mod,"MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & - units='m', default=1.e-3) + units='m', default=1.e-3, scale=GV%m_to_H) call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & units='days', default=0.0, scale=86400.0*US%s_to_T) @@ -117,10 +117,10 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C "Nudge velocities (u and v) towards zero in the sponge layer.", & default=.false., do_not_log=.true.) - T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 ; RHO(:,:,:) = 0.0 + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 call get_param(PF, mod, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) if (associated(CSp)) call MOM_error(FATAL, & "RGC_initialize_sponges called with an associated control structure.") @@ -147,11 +147,6 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! 1) Read eta, salt and temp from IC file call get_param(PF, mod, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - ! GM: get two different files, one with temp and one with salt values - ! this is work around to avoid having wrong values near the surface - ! because of the FIT_SALINITY option. To get salt values right in the - ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can - ! combined the *correct* temp and salt values in one file instead. call get_param(PF, mod, "RGC_SPONGE_FILE", state_file, & "The name of the file with temps., salts. and interfaces to \n"// & " damp toward.", fail_if_missing=.true.) @@ -176,12 +171,12 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) if (use_ALE) then - call MOM_read_data(filename, h_var, h(:,:,:), G%Domain) + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=GV%m_to_H) 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. ! + ! The remaining calls to set_up_sponge_field can be in any order. if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) @@ -194,7 +189,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C else ! layer mode !read eta - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) ! Set the sponge damping rates so that the model will know where to ! apply the sponges, along with the interface heights. From 8c6ae0eea8eb224f30a42b88e3c8ee6d6ab03b80 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Mar 2022 10:53:12 -0400 Subject: [PATCH 062/155] Corrected the license on RGC_initialization.F90 Corrected the license on RGC_initialization.F90 to refer to the same LICENSE.md file as the rest of the MOM6 code, with the explicit written consent of the contributors to this file. Also changed the local variable "mod" into "mdl" in this module to avoid some of the problems we had previously found with some compilers from reusing an intrinsic function name for a variable name. All answers are bitwise identical. --- src/user/RGC_initialization.F90 | 55 ++++++++++++++------------------- 1 file changed, 23 insertions(+), 32 deletions(-) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index a3e22de81a..f2cd80d612 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -1,22 +1,9 @@ +!> Configures the models sponges for the Rotating Gravity Current (RGC) experiment. module RGC_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + !*********************************************************************** -!* GNU General Public License * -!* This file is a part of MOM. * -!* * -!* MOM is free software; you can redistribute it and/or modify it and * -!* are expected to follow the terms of the GNU General Public License * -!* as published by the Free Software Foundation; either version 2 of * -!* the License, or (at your option) any later version. * -!* * -!* MOM is distributed in the hope that it will be useful, but WITHOUT * -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * -!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * -!* License for more details. * -!* * -!* For the full text of the GNU General Public License, * -!* write to: Free Software Foundation, Inc., * -!* 675 Mass Ave, Cambridge, MA 02139, USA. * -!* or see: http://www.gnu.org/licenses/gpl.html * !* By Elizabeth Yankovsky, May 2018 * !*********************************************************************** @@ -39,9 +26,13 @@ module RGC_initialization #include -character(len=40) :: mod = "RGC_initialization" ! This module's name. public RGC_initialize_sponges +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + contains !> Sets up the the inverse restoration time, and the values towards which the interface heights, @@ -86,7 +77,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var - character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + character(len=40) :: mdl = "RGC_initialize_sponges" ! This subroutine's name. 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 @@ -95,31 +86,31 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB ! The variable min_thickness is unused, and can probably be eliminated. - call get_param(PF, mod,"MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & units='m', default=1.e-3, scale=GV%m_to_H) - call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & + call get_param(PF, mdl, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & units='days', default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mod, "LENLAT", lenlat, & + call get_param(PF, mdl, "LENLAT", lenlat, & "The latitudinal or y-direction length of the domain", & fail_if_missing=.true., do_not_log=.true.) - call get_param(PF, mod, "LENLON", lenlon, & + call get_param(PF, mdl, "LENLON", lenlon, & "The longitudinal or x-direction length of the domain", & fail_if_missing=.true., do_not_log=.true.) - call get_param(PF, mod, "LENSPONGE", lensponge, & + call get_param(PF, mdl, "LENSPONGE", lensponge, & "The length of the sponge layer (km).", & default=10.0) - call get_param(PF, mod, "SPONGE_UV", sponge_uv, & + call get_param(PF, mdl, "SPONGE_UV", sponge_uv, & "Nudge velocities (u and v) towards zero in the sponge layer.", & default=.false., do_not_log=.true.) T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 - call get_param(PF, mod, "MINIMUM_DEPTH", min_depth, & + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) if (associated(CSp)) call MOM_error(FATAL, & @@ -145,21 +136,21 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! 1) Read eta, salt and temp from IC file - call get_param(PF, mod, "INPUTDIR", inputdir, default=".") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mod, "RGC_SPONGE_FILE", state_file, & + call get_param(PF, mdl, "RGC_SPONGE_FILE", state_file, & "The name of the file with temps., salts. and interfaces to \n"// & " damp toward.", fail_if_missing=.true.) - call get_param(PF, mod, "SPONGE_PTEMP_VAR", temp_var, & + call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & "The name of the potential temperature variable in \n"//& "SPONGE_STATE_FILE.", default="Temp") - call get_param(PF, mod, "SPONGE_SALT_VAR", salt_var, & + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & "The name of the salinity variable in \n"//& "SPONGE_STATE_FILE.", default="Salt") - call get_param(PF, mod, "SPONGE_ETA_VAR", eta_var, & + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & "The name of the interface height variable in \n"//& "SPONGE_STATE_FILE.", default="eta") - call get_param(PF, mod, "SPONGE_H_VAR", h_var, & + call get_param(PF, mdl, "SPONGE_H_VAR", h_var, & "The name of the layer thickness variable in \n"//& "SPONGE_STATE_FILE.", default="h") From ab4d226bb8ea14d58f6176839cc80c56e8ff7b0a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 10 Mar 2022 14:47:56 -0500 Subject: [PATCH 063/155] +(*)MOM_hor_visc bug fix and loop size cleanup Fixed the bug noted in issue #72 and excessive loop sizes noted in the unresolved comments in a recent commit, and cleaned up other aspects of MOM_hor_visc, mostly related to the code that is exercised when USE_GME=True. - Fixed the bug with the wrong arrays being used when ADD_LES_VISCOSITY=True that was noted in MOM6 issue #72. - Corrected some of the overly large loop extents that were noted in unresolved comments about MOM6 PR #65. - Only log USE_KH_BG_2D if a Laplacian viscosity is used. - Use extra calculations in the halos and marching in to avoid unnecessary halo updates in smooth_GME if there multiple smoothing passes. - Corrected the capitalization of some horizontal indices to follow the MOM6 convention for indicating the horizontal staggering position. - Collected the post_data calls for diagnostics with use_GME with the other post data calls to collocate some of the potential inter-PE synchronization points. - Fixed the indentation of some expressions that were using less than 4 points for some continuation lines. - Eliminated several unused variables, and fused some loops to allow 2-d variables to be replaced with scalars. With this PR, answers can change when ADD_LES_VISCOSITY=True and there is a Smagorinsky or Leith Laplacian viscosity and there is a nonzero background. One run-time parameter is no longer logged if LAPLACIAN=false, so there are changes to the MOM_parameter_doc files. All answers in the MOM6-examples test suite are bitwise identical. --- .../lateral/MOM_hor_visc.F90 | 350 +++++++++--------- 1 file changed, 170 insertions(+), 180 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 78f48975e5..2cc6b99370 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -273,20 +273,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] 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] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] - grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_vel_mag_bt_h, & ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot, & ! The total thickness of all layers [Z ~> m] - boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - - real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: diffu_visc_rem ! diffu x visc_rem_u [L T-2 ~> m s-2] - real, allocatable, dimension(:,:,:) :: diffv_visc_rem ! diffv x visc_rem_v [L T-2 ~> m s-2] + htot ! The total thickness of all layers [Z ~> m] + real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] + real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] + real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] @@ -304,12 +297,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] - 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. - grad_vel_mag_bt_q, & ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] - GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] - boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] + GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] + real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] @@ -391,13 +383,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! 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! + ! NOTE: Several of these are declared with the memory extent of q-points, but the + ! same arrays are also used at h-points to reduce the memory footprint of this + ! module, so they should never be used in halo point or checksum calls. 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] + Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] + Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] + vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] 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] + visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] @@ -456,14 +451,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - boundary_mask_h(i,j) = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) - enddo ; enddo - - do J=Jsq-2,Jeq+1 ; do I=Isq-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 - ! initialize diag. array with zeros GME_coeff_h(:,:,:) = 0.0 GME_coeff_q(:,:,:) = 0.0 @@ -474,13 +461,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call barotropic_get_tav(BT, ubtav, vbtav, G, US) call pass_vector(ubtav, vbtav, G%Domain) + call pass_var(h, G%domain, halo=2) ! Calculate the barotropic horizontal tension - do j=Jsq-2,Jeq+2 ; do i=Isq-2,Ieq+2 + do J=js-2,je+2 ; do I=is-2,ie+2 dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & G%IdyCu(I-1,j) * ubtav(I-1,j)) dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & G%IdxCv(i,J-1) * vbtav(i,J-1)) + enddo ; enddo + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) enddo ; enddo @@ -492,12 +482,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, - ubtav(I,j)*G%IdxCu(I,j)) enddo ; enddo - ! post barotropic tension and strain - if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) - if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) - if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) - if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) - if (CS%no_slip) then do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) @@ -508,20 +492,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - grad_vel_mag_bt_h(i,j) = G%mask2dT(I,J) * boundary_mask_h(i,j) * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & - (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1))+(dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & - (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1))+(dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) - enddo ; enddo - - do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 - grad_vel_mag_bt_q(I,J) = G%mask2dBu(I,J) * boundary_mask_q(I,J) * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & - (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1))+(dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & - (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1))+(dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) - enddo ; enddo - - call pass_var(h, G%domain, halo=2) - do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = 0.0 enddo ; enddo @@ -531,7 +501,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, I_GME_h0 = 1.0 / CS%GME_h0 do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - if (grad_vel_mag_bt_h(i,j)>0) then + boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) + grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & + (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & + (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then + if (grad_vel_mag_bt_h > 0.0) then GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * & (MIN(htot(i,j) * I_GME_h0, 1.0)**2) else @@ -539,12 +515,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif enddo ; enddo - do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 - if (grad_vel_mag_bt_q(I,J)>0) then + do J=js-2,je+1 ; do I=is-2,ie+1 + boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) + grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & + (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & + (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then + if (grad_vel_mag_bt_q > 0.0) then h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) I_hq = 1.0 / h_arith_q h_harm_q = 0.25 * h_arith_q * ((htot(i,j)*I_hq + htot(i+1,j+1)*I_hq) + & (htot(i+1,j)*I_hq + htot(i,j+1)*I_hq)) + !### The two expressions above looks like they simplify to just the arithmetic mean! + ! Why not just h_harm_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) ? GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) else GME_effic_q(I,J) = 0.0 @@ -565,7 +549,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & + !$OMP use_MEKE_Ku, use_MEKE_Au, & !$OMP backscat_subround, GME_coeff_limiter, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & @@ -580,8 +564,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$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, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & - !$OMP grad_vel_mag_h, grad_vel_mag_q, sh_xx_sq, sh_xy_sq, & - !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & + !$OMP sh_xx_sq, sh_xy_sq, & !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & @@ -831,9 +814,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) enddo ; enddo - do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 - Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) - enddo ; enddo if (CS%modified_Leith) then @@ -1017,8 +997,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 - ! ### NOTE: The denominator could be zero here - AJA ### + else ! if (Kh(i,j) > 0.0) then !### Change this to avoid a zero denominator. visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) endif enddo ; enddo @@ -1094,7 +1073,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6 Ah(i,j) = max(Ah(i,j), AhLth) enddo ; enddo endif @@ -1215,7 +1196,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%better_bound_Kh) then do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(i,j) = 1.0 + visc_bound_rem(I,J) = 1.0 enddo ; enddo endif endif @@ -1264,17 +1245,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Static (pre-computed) background viscosity do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = CS%Kh_bg_xy(i,j) + 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) + Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xy(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) ) + Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) ) enddo ; enddo endif endif @@ -1282,7 +1263,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_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%Laplac3_const_xx(i,j) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA + Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1314,17 +1295,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn endif - ! Older method of bounding for stability 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(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 (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then + 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 (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then !### Change to elseif (Kh(I,J) > 0.0) then visc_bound_rem(I,J) = 1.0 - Kh(I,J) / (hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif endif @@ -1340,7 +1320,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(i,j) * sh_xy(I,J) + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1353,7 +1333,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! 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 + 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 enddo ; enddo endif @@ -1361,7 +1341,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Determine the biharmonic viscosity at q points, using the ! largest value from several parameterizations. do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = CS%Ah_bg_xy(I,J) + Ah(I,J) = CS%Ah_bg_xy(I,J) enddo ; enddo if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then @@ -1371,7 +1351,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + Ah(I,J) = max(Ah(I,J), AhSm) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1407,18 +1387,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J) enddo ; enddo endif 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)) + 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)) + Ah(I,J) = min(Ah(I,J), hrat_min(I,J) * CS%Ah_Max_xy(I,J)) enddo ; enddo endif endif @@ -1441,6 +1421,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%use_GME) then + ! The wider halo here is to permit one pass of smoothing without a halo update. do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 GME_coeff = GME_effic_h(i,j) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) @@ -1450,7 +1431,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx_GME(i,j) = GME_coeff * sh_xx_bt(i,j) enddo ; enddo - do J=Jsq-2,Jeq+1 ; do I=Isq-2,Ieq+1 + ! The wider halo here is to permit one pass of smoothing without a halo update. + do J=js-2,je+1 ; do I=is-2,ie+1 GME_coeff = GME_effic_q(I,J) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) @@ -1463,7 +1445,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call smooth_GME(CS, G, GME_flux_h=str_xx_GME) call smooth_GME(CS, G, GME_flux_q=str_xy_GME) - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo @@ -1496,10 +1478,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. do j=js,je ; do I=Isq,Ieq - diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j) *str_xx(i,j) - & - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & - G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & - CS%dx2q(I,J) *str_xy(I,J))) * & + diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j)*str_xx(i,j) - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & + 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 @@ -1518,10 +1498,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. do J=Jsq,Jeq ; do i=is,ie - diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - & - CS%dy2q(I,J) *str_xy(I,J)) - & - G%IdxCv(i,J)*(CS%dx2h(i,j) *str_xx(i,j) - & - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & + diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - CS%dy2q(I,J)*str_xy(I,J)) - & + G%IdxCv(i,J)*(CS%dx2h(i,j)*str_xx(i,j) - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) enddo ; enddo @@ -1542,20 +1520,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion FrictWork(i,j,k) = GV%H_to_RZ * ( & - (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*((str_xy(I,J)*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +str_xy(I-1,J-1)*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +(str_xy(I-1,J)*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +str_xy(I,J-1)*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + (str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo ; endif if (CS%use_GME) then @@ -1564,19 +1542,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! This is the old formulation that includes energy diffusion FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*((str_xy_GME(I,J)*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +str_xy_GME(I-1,J-1)*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +(str_xy_GME(I-1,J)*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +str_xy_GME(I,J-1)*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy_GME(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy_GME(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy_GME(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy_GME(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo ; endif ! Make a similar calculation as for FrictWork above but accumulating into @@ -1621,18 +1599,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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)) & - +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + + 0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & + + (str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + ((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + (str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo endif ! MEKE%backscatter_Ro_c @@ -1656,19 +1634,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) - if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) - if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) - if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) - if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) - if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%use_GME) then ! post barotropic tension and strain + if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) + if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) + if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) + if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) + if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) + if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) + endif if (CS%debug) then if (CS%Laplacian) then @@ -2003,7 +1987,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & "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.) ! ###do_not_log=.not.CS%Laplacian? + "terms and this background value.", default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false. call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is"//& @@ -2514,25 +2499,25 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt endif if (CS%use_GME) then - CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & + CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & 'Zonal component of the barotropic shearing strain at h points', 's-1', & conversion=US%s_to_T) - CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & + CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & 'Zonal component of the barotropic shearing strain at q points', 's-1', & conversion=US%s_to_T) - CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & + CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & 'Meridional component of the barotropic shearing strain at h points', 's-1', & conversion=US%s_to_T) - CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & + CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & 'Meridional component of the barotropic shearing strain at q points', 's-1', & conversion=US%s_to_T) - CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & + CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & + CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& - 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& + 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& 'Integral work done by lateral friction terms. If GME is turned on, this '//& @@ -2577,57 +2562,62 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing - integer :: i, j, k, s + integer :: i, j, k, s, halosz + integer :: xh, xq ! The number of valid extra halo points for h and q points. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + xh = 0 ; xq = 0 + do s=1,CS%num_smooth_gme if (present(GME_flux_h)) then - ! Update halos if needed - if (s >= 2) call pass_var(GME_flux_h, G%Domain) + if (xh < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_h, G%Domain, halo=halosz) + xh = halosz - 2 + endif GME_flux_h_original(:,:) = GME_flux_h(:,:) ! apply smoothing on GME - do j = Jsq, Jeq+1 - do i = Isq, Ieq+1 - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dT(i-1,j) - we = 0.125 * G%mask2dT(i+1,j) - ws = 0.125 * G%mask2dT(i,j-1) - wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - ((ww+we)+(wn+ws)) - GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & - + ((ww * GME_flux_h_original(i-1,j) & - + 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 + do j=Jsq-xh,Jeq+1+xh ; do i=Isq-xh,Ieq+1+xh + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + + ((ww * GME_flux_h_original(i-1,j) + 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 + xh = xh - 1 endif if (present(GME_flux_q)) then - ! Update halos if needed - if (s >= 2) call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) + if (xq < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true., halo=halosz) + xq = halosz - 2 + endif GME_flux_q_original(:,:) = GME_flux_q(:,:) ! apply smoothing on GME - do J = Jsq-1, Jeq - do I = Isq-1, Ieq - ! skip land points - if (G%mask2dBu(I,J)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dBu(I-1,J) - we = 0.125 * G%mask2dBu(I+1,J) - ws = 0.125 * G%mask2dBu(I,J-1) - wn = 0.125 * G%mask2dBu(I,J+1) - wc = 1.0 - ((ww+we)+(wn+ws)) - GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & - + ((ww * GME_flux_q_original(I-1,J) & - + 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 + do J=js-1-xq,je+xq ; do I=is-1-xq,ie+xq + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dBu(I-1,J) + we = 0.125 * G%mask2dBu(I+1,J) + ws = 0.125 * G%mask2dBu(I,J-1) + wn = 0.125 * G%mask2dBu(I,J+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + + ((ww * GME_flux_q_original(I-1,J) + 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 + xq = xq - 1 endif enddo ! s-loop end subroutine smooth_GME From 966d50f15f221a3292ed6aced4aa500b7c1e1072 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 17 Mar 2022 08:10:28 -0400 Subject: [PATCH 064/155] (*)Minor MOM_hor_visc code cleanup Minor code cleanup in response to the code review from Gustavo Marques. In particular, this introduces a roundoff-level answer changing code simplification for code that is only exercised if USE_GME=True. In all other cases the answers are bitwise identical. --- .../lateral/MOM_hor_visc.F90 | 25 ++++++------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2cc6b99370..8e26014996 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -339,8 +339,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! points; these are first interpolated to u or v velocity ! points where masks are applied [H ~> m or kg m-2]. real :: h_arith_q ! The arithmetic mean total thickness at q points [Z ~> m] - real :: h_harm_q ! The harmonic mean total thickness at q points [Z ~> m] - real :: I_hq ! The inverse of the arithmetic mean total thickness at q points [Z-1 ~> m-1] real :: I_GME_h0 ! The inverse of GME tapering scale [Z-1 ~> m-1] real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] @@ -501,22 +499,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, I_GME_h0 = 1.0 / CS%GME_h0 do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) + boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCu(I-1,j)) * (G%mask2dCv(i,J) * G%mask2dCv(i,J-1)) grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) ! Probably the following test could be simplified to ! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then if (grad_vel_mag_bt_h > 0.0) then - GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * & - (MIN(htot(i,j) * I_GME_h0, 1.0)**2) + GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * (MIN(htot(i,j) * I_GME_h0, 1.0)**2) else GME_effic_h(i,j) = 0.0 endif enddo ; enddo do J=js-2,je+1 ; do I=is-2,ie+1 - boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) + boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) * (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) @@ -524,12 +521,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then if (grad_vel_mag_bt_q > 0.0) then h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) - I_hq = 1.0 / h_arith_q - h_harm_q = 0.25 * h_arith_q * ((htot(i,j)*I_hq + htot(i+1,j+1)*I_hq) + & - (htot(i+1,j)*I_hq + htot(i,j+1)*I_hq)) - !### The two expressions above looks like they simplify to just the arithmetic mean! - ! Why not just h_harm_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) ? - GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) + GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_arith_q * I_GME_h0, 1.0)**2) else GME_effic_q(I,J) = 0.0 endif @@ -1536,11 +1528,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo ; endif - if (CS%use_GME) then - do j=js,je ; do i=is,ie - ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) - ! This is the old formulation that includes energy diffusion - FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + if (CS%use_GME) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + 0.25*((str_xy_GME(I,J) * & From 11d03b13bce3e8a2028d5c8fb80a84d0164fab44 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 Mar 2022 09:59:53 -0400 Subject: [PATCH 065/155] +Add unit conversion capability for restarts Added optional arguments to framework code to permit the restart files to work with dimensionally unscaled variables. All answers are bitwise identical, but there are new optional arguments for multiple public interfaces. - Added a new conversion factor element, conv, to the field_restart type to specify how a field is to be unscaled before writing, and whose reciprocal is used to scale restart fields as they are read in. - Added the new optional argument conversion to each of the register_restart_field() and register_restart_pair() routines, which is used to specify how each field will be rescaled when it is written to or read from a restart file. The default is the same as setting this to 1. - Added the new optional argument unscaled to fix_restart_scaling() and fix_restart_unit_scaling() to reset the unit conversion factors that will be save to the restart files to 1, consistent with writing out fields without scaling to the restart files. --- src/core/MOM_verticalGrid.F90 | 9 +- src/framework/MOM_restart.F90 | 178 ++++++++++++++++++----------- src/framework/MOM_unit_scaling.F90 | 13 ++- 3 files changed, 133 insertions(+), 67 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a340b5f80f..2df65f09aa 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -188,10 +188,17 @@ subroutine verticalGridInit( param_file, GV, US ) end subroutine verticalGridInit !> Set the scaling factors for restart files to the scaling factors for this run. -subroutine fix_restart_scaling(GV) +subroutine fix_restart_scaling(GV, unscaled) type(verticalGrid_type), intent(inout) :: GV !< The ocean's vertical grid structure + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. GV%m_to_H_restart = GV%m_to_H + if (present(unscaled)) then ; if (unscaled) then + GV%m_to_H_restart = 1.0 + endif ; endif + end subroutine fix_restart_scaling !> Returns the model's thickness units, usually m or kg/m^2. diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 1328fd676c..a5386ce7fa 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -59,6 +59,10 @@ module MOM_restart !! read from the restart file. logical :: initialized !< .true. if this field has been read from the restart file. character(len=32) :: var_name !< A name by which a variable may be queried. + real :: conv = 1.0 !< A factor by which a restart field should be multiplied before it + !! is written to a restart file, usually to convert it to MKS or + !! other standard units. When read, the restart field is multiplied + !! by the Adcroft reciprocal of this factor. end type field_restart !> A structure to store information about restart fields that are no longer used @@ -146,13 +150,15 @@ subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) end subroutine register_restart_field_as_obsolete !> Register a 3-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -166,6 +172,8 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr3d") @@ -179,13 +187,15 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr3d !> Register a 4-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -199,6 +209,8 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr4d") @@ -212,13 +224,15 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr4d !> Register a 2-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -232,6 +246,8 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr2d") @@ -245,12 +261,14 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -264,6 +282,8 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr1d") @@ -277,12 +297,14 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS, conversion) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -296,6 +318,8 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr0d") @@ -311,66 +335,72 @@ end subroutine register_restart_field_ptr0d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr2d !> Register a pair of rotationally equivalent 3d restart fields subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr3d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr4d @@ -378,7 +408,7 @@ end subroutine register_restart_pair_ptr4d ! The following provide alternate interfaces to register restarts. !> Register a 4-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -388,6 +418,8 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. 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 @@ -403,12 +435,12 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -418,6 +450,8 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. 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 @@ -433,12 +467,12 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_3d !> Register a 2-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -448,6 +482,8 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. 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 @@ -466,12 +502,12 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=zgrid, t_grid=t_grid) - call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_2d !> Register a 1-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file @@ -480,6 +516,8 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. 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 @@ -498,12 +536,12 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_1d !> Register a 0-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, conversion, & t_grid) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file @@ -512,6 +550,8 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd @@ -525,7 +565,7 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid='1', & z_grid='1', t_grid=t_grid) - call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_0d @@ -910,6 +950,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. character(len=64) :: var_name ! A variable's name. + real :: conv ! Shorthand for the conversion factor real :: restart_time character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. @@ -1025,16 +1066,17 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) endif do m=start_var,next_var-1 + conv = CS%restart_field(m)%conv if (associated(CS%var_ptr3d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*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) = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*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) = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*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) = chksum(CS%var_ptr1d(m)%p) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr1d(m)%p(:)) elseif (associated(CS%var_ptr0d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) endif enddo @@ -1048,18 +1090,20 @@ 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 MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr3d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr2d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr2d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr4d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr4d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - call MOM_write_field(IO_handle, 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, scale=CS%restart_field(m)%conv) elseif (associated(CS%var_ptr0d(m)%p)) then - call MOM_write_field(IO_handle, 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, scale=CS%restart_field(m)%conv) endif enddo @@ -1085,6 +1129,8 @@ subroutine restore_state(filename, directory, day, G, CS) type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct ! Local variables + real :: scale ! A scaling factor for reading a field + real :: conv ! The output conversion factor for writing a field character(len=200) :: filepath ! The path (dir/file) to the file being opened. character(len=80) :: fname ! The name of the current file. character(len=8) :: suffix ! A suffix (like "_2") that is added to any @@ -1198,6 +1244,8 @@ subroutine restore_state(filename, directory, day, G, CS) case ('1') ; pos = 0 case default ; pos = 0 end select + conv = CS%restart_field(m)%conv + if (conv == 0.0) then ; scale = 1.0 ; else ; scale = 1.0 / conv ; endif call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do i=1, nvar @@ -1214,42 +1262,42 @@ 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, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*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, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*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, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. 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)) + if (is_there_a_checksum) checksum_data = chksum(conv*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, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. 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,:)) + if (is_there_a_checksum) checksum_data = chksum(conv*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, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 4-d arrays without domain decomposition.") ! 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,:,:)) + if (is_there_a_checksum) checksum_data = chksum(conv*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 diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index cd339f410c..bf8fd24b44 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -196,8 +196,11 @@ end subroutine set_unit_scaling_combos !> Set the unit scaling factors for output to restart files to the unit scaling !! factors for this run. -subroutine fix_restart_unit_scaling(US) +subroutine fix_restart_unit_scaling(US, unscaled) type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. US%m_to_Z_restart = US%m_to_Z US%m_to_L_restart = US%m_to_L @@ -205,6 +208,14 @@ subroutine fix_restart_unit_scaling(US) US%kg_m3_to_R_restart = US%kg_m3_to_R US%J_kg_to_Q_restart = US%J_kg_to_Q + if (present(unscaled)) then ; if (unscaled) then + US%m_to_Z_restart = 1.0 + US%m_to_L_restart = 1.0 + US%s_to_T_restart = 1.0 + US%kg_m3_to_R_restart = 1.0 + US%J_kg_to_Q_restart = 1.0 + endif ; endif + end subroutine fix_restart_unit_scaling !> Deallocates a unit scaling structure. From 7c3f31bd473da8c0a9fef327bf14b0ba56aadc95 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 Mar 2022 10:32:36 -0400 Subject: [PATCH 066/155] +(*)Write unscaled MOM6 restart files Revised the MOM6 code so that the output restart files are always exactly the same as they would be if no dimensional rescaling is applied. The input restart files can still have rescaling, so files written by previous versions of the code still work exactly as before. This does change the output, in the sense that the restart files are unscaled and some units documents in the restart files are corrected, but the solutions themselves are bitwise identical. Also, there are new (non-optional) unit scaling type arguments to several routines. The specific changes in this commit include: - Added conversion factors to all register_restart_field() or register_restart_pair() call for variables that are subject to dimensional rescaling. - Revised the calculation of restart rescaling factors to reflect the rescaling that now occurs directly in the restore_state() call. - Added new US arguments to register_restarts_dyn_split_RK2(), MEKE_alloc_register_restart(), set_visc_register_restarts() - Added a new GV argument to mixedlayer_restrat_register_restarts() - Used the new unscaled argument in calls to fix_restart_scaling() and fix_restart_unit_scaling() - Revised several calls to register_restart_field() to avoid using the variant that uses a var_desc type, eliminating the need for some modules to reference the vardesc type or the routine var_desc(). - Added or corrected unit descriptions to the comments describing a few variables. - Noted a few probably bugs in comments with ###, but did not fix them. --- src/core/MOM.F90 | 55 +++++++--------- src/core/MOM_barotropic.F90 | 26 ++++---- src/core/MOM_dynamics_split_RK2.F90 | 66 +++++++++---------- src/core/MOM_open_boundary.F90 | 64 ++++++++++-------- src/ice_shelf/MOM_ice_shelf.F90 | 24 +++---- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 27 ++++---- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 49 +++++++------- .../MOM_state_initialization.F90 | 11 ++-- src/ocean_data_assim/MOM_oda_incupd.F90 | 52 +++++++-------- src/parameterizations/lateral/MOM_MEKE.F90 | 65 +++++++++--------- .../lateral/MOM_internal_tides.F90 | 10 ++- .../lateral/MOM_mixed_layer_restrat.F90 | 28 ++++---- .../vertical/MOM_set_viscosity.F90 | 25 +++---- src/tracer/boundary_impulse_tracer.F90 | 6 +- src/user/MOM_controlled_forcing.F90 | 36 +++++----- 15 files changed, 280 insertions(+), 264 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8f6dab2a1a..5b35c01a42 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2422,7 +2422,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call restart_init(param_file, restart_CSp) call set_restart_fields(GV, US, param_file, CS, restart_CSp) if (CS%split) then - call register_restarts_dyn_split_RK2(HI, GV, param_file, & + call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) elseif (CS%use_RK2) then call register_restarts_dyn_unsplit_RK2(HI, GV, param_file, & @@ -2437,9 +2437,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call call_tracer_register(HI, GV, US, param_file, CS%tracer_flow_CSp, & CS%tracer_Reg, restart_CSp) - call MEKE_alloc_register_restart(HI, param_file, CS%MEKE, restart_CSp) - call set_visc_register_restarts(HI, GV, param_file, CS%visc, restart_CSp) - call mixedlayer_restrat_register_restarts(HI, param_file, & + call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) + call set_visc_register_restarts(HI, GV, US, param_file, CS%visc, restart_CSp) + call mixedlayer_restrat_register_restarts(HI, GV, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then @@ -2468,7 +2468,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This needs the number of tracers and to have called any code that sets whether ! reservoirs are used. - call open_boundary_register_restarts(HI, GV, CS%OBC, CS%tracer_Reg, & + call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) endif @@ -2865,11 +2865,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_frazil) then if (query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then ! Test whether the dimensional rescaling has changed for heat content. - if ((US%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) /= & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart)) ) then - QRZ_rescale = (US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) / & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) + if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 0.0) .and. & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 1.0) ) then + QRZ_rescale = 1.0 / (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) do j=js,je ; do i=is,ie CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) enddo ; enddo @@ -2885,10 +2883,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%p_surf_prev_set) then ! Test whether the dimensional rescaling has changed for pressure. if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - ((US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) /= & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2)) ) then - RL2_T2_rescale = (US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) / & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2) + (US%s_to_T_restart**2 /= US%kg_m3_to_R_restart * US%m_to_L_restart**2) ) then + RL2_T2_rescale = US%s_to_T_restart**2 / (US%kg_m3_to_R_restart*US%m_to_L_restart**2) do j=js,je ; do i=is,ie CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) enddo ; enddo @@ -2901,8 +2897,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_ice_shelf .and. associated(CS%Hml)) then if (query_initialized(CS%Hml, "hML", restart_CSp)) then ! Test whether the dimensional rescaling has changed for depths. - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=js,je ; do i=is,ie CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) enddo ; enddo @@ -2911,8 +2907,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=js,je ; do i=is,ie CS%ave_ssh_ibc(i,j) = Z_rescale * CS%ave_ssh_ibc(i,j) enddo ; enddo @@ -2967,7 +2963,6 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! various unit conversion factors type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() real, allocatable :: z_interface(:,:,:) ! Interface heights [m] - type(vardesc) :: vd call cpu_clock_begin(id_clock_init) call callTree_enter("finish_MOM_initialization()") @@ -2976,8 +2971,8 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) G => CS%G ; GV => CS%GV ; US => CS%US !### Move to initialize_MOM? - call fix_restart_scaling(GV) - call fix_restart_unit_scaling(US) + call fix_restart_scaling(GV, unscaled=.true.) + call fix_restart_unit_scaling(US, unscaled=.true.) if (CS%use_particles) then @@ -3090,9 +3085,6 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') - v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') - if (associated(CS%tv%T)) & call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & "Potential Temperature", "degC") @@ -3101,28 +3093,31 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Salinity", "PPT") call register_restart_field(CS%h, "h", .true., restart_CSp, & - "Layer Thickness", thickness_units) + "Layer Thickness", thickness_units, conversion=GV%H_to_MKS) - call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp) + u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') + v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp, conversion=US%L_T_to_m_s) if (associated(CS%tv%frazil)) & call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & - "Frazil heat flux into ocean", "J m-2") + "Frazil heat flux into ocean", & + "J m-2", conversion=US%Q_to_J_kg*US%RZ_to_kg_m2) if (CS%interp_p_surf) then call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., restart_CSp, & - "Previous ocean surface pressure", "Pa") + "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) endif call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & - "Time average sea surface height", "meter") + "Time average sea surface height", "meter", conversion=US%Z_to_m) ! hML is needed when using the ice shelf module call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter") + "Mixed layer thickness", "meter", conversion=US%Z_to_m) endif ! Register scalar unit conversion factors. diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3cb1ebf399..3b5c812ba1 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4748,8 +4748,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, dtbt_tmp = -1.0 if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then dtbt_tmp = CS%dtbt - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - dtbt_tmp = (US%s_to_T / US%s_to_T_restart) * CS%dtbt + if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & + dtbt_tmp = (1.0 / US%s_to_T_restart) * CS%dtbt endif ! Estimate the maximum stable barotropic time step. @@ -4909,8 +4909,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%vbtav(i,J) = CS%vbtav(i,J) + CS%frhatv(i,J,k) * v(i,J,k) enddo ; enddo ; enddo elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif @@ -4921,8 +4921,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo endif @@ -5022,11 +5022,12 @@ end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 !! that should be written to or read from the restart file. -subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) +subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(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(barotropic_CS), intent(inout) :: CS !< Barotropic control structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables @@ -5056,7 +5057,8 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='u', z_grid='1') vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) if (CS%gradual_BT_ICs) then vd(2) = var_desc("ubt_IC", "m s-1", & @@ -5065,12 +5067,12 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) vd(3) = var_desc("vbt_IC", "m s-1", & longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) endif - call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & - longname="Barotropic timestep", units="seconds") + longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) end subroutine register_barotropic_restarts diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f22fb9a862..d177e63be8 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -972,9 +972,10 @@ end subroutine step_MOM_dyn_split_RK2 !> This subroutine sets up any auxiliary restart variables that are specific !! to the split-explicit time stepping scheme. All variables registered here should !! have the ability to be recreated if they are not present in a restart file. -subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, uh, vh) +subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_CS, uh, vh) type(hor_index_type), intent(in) :: HI !< Horizontal index structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< parameter file type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure @@ -1016,29 +1017,32 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u flux_units = get_flux_units(GV) if (GV%Boussinesq) then - vd(1) = var_desc("sfc",thickness_units,"Free surface Height",'h','1') + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) else - vd(1) = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) endif - call register_restart_field(CS%eta, vd(1), .false., restart_CS) - vd(1) = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') - vd(2) = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') - call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') + vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) - vd(1) = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') - call register_restart_field(CS%h_av, vd(1), .false., restart_CS) + call register_restart_field(CS%h_av, "h2", .false., restart_CS, & + longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) - vd(1) = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') - vd(2) = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') - call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') + vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & + conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) - vd(1) = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') - vd(2) = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') - call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') + vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) - call register_barotropic_restarts(HI, GV, param_file, CS%barotropic_CSp, & - restart_CS) + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) end subroutine register_restarts_dyn_split_RK2 @@ -1238,8 +1242,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do j=js,je ; do i=is,ie CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo - 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 + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=js,je ; do i=is,ie ; CS%eta(i,j) = H_rescale * CS%eta(i,j) ; enddo ; enddo endif ! Copy eta into an output array. @@ -1251,14 +1255,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%diffu,"diffu",restart_CS) .or. & .not. query_initialized(CS%diffv,"diffv",restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, & - TD=thickness_diffuse_CSp) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) else if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L * US%s_to_T_restart**2 /= US%m_to_L_restart * US%s_to_T**2) ) then - accel_rescale = (US%m_to_L * US%s_to_T_restart**2) / (US%m_to_L_restart * US%s_to_T**2) + (US%s_to_T_restart**2 /= US%m_to_L_restart) ) then + accel_rescale = US%s_to_T_restart**2 / US%m_to_L_restart do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB CS%diffu(I,j,k) = accel_rescale * CS%diffu(I,j,k) enddo ; enddo ; enddo @@ -1273,8 +1275,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = v(i,J,k) ; enddo ; enddo ; enddo elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo endif @@ -1291,15 +1293,13 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param else if (.not. query_initialized(CS%h_av,"h2",restart_CS)) then CS%h_av(:,:,:) = h(:,:,:) - 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 + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do k=1,nz ; do j=js,je ; do i=is,ie ; CS%h_av(i,j,k) = H_rescale * CS%h_av(i,j,k) ; enddo ; enddo ; enddo endif if ( (GV%m_to_H_restart * US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) /= & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T)) ) then - uH_rescale = (GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) / & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T) + (US%s_to_T_restart /= (GV%m_to_H_restart * US%m_to_L_restart**2)) ) then + uH_rescale = US%s_to_T_restart / (GV%m_to_H_restart * US%m_to_L_restart**2) do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB ; uh(I,j,k) = uH_rescale * uh(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie ; vh(i,J,k) = uH_rescale * vh(i,J,k) ; enddo ; enddo ; enddo endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5fc168f5a4..6ce0940ddb 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1821,8 +1821,8 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to ! permit timesteps to change between calls to the OBC code, the following would be needed: ! if ( OBC%radiation_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & -! ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then -! vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) +! (US%s_to_T_restart /= US%m_to_L_restart) ) then +! vel_rescale = US%s_to_T_restart / US%m_to_L_restart ! if (query_initialized(OBC%rx_normal, "rx_normal", restart_CS)) then ! do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ! OBC%rx_normal(I,j,k) = vel_rescale * OBC%rx_normal(I,j,k) @@ -1837,8 +1837,8 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) ! The oblique boundary condition terms have units of [L2 T-2 ~> m2 s-2] and may need to be rescaled. if ( OBC%oblique_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel2_rescale = (US%m_to_L * US%s_to_T_restart)**2 / (US%m_to_L_restart * US%s_to_T)**2 + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel2_rescale = US%s_to_T_restart**2 / US%m_to_L_restart**2 if (query_initialized(OBC%rx_oblique, "rx_oblique", restart_CS)) then do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB OBC%rx_oblique(I,j,k) = vel2_rescale * OBC%rx_oblique(I,j,k) @@ -4910,10 +4910,11 @@ subroutine flood_fill2(G, color, cin, cout, cland) end subroutine flood_fill2 !> Register OBC segment data for restarts -subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart_CS, & +subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, restart_CS, & use_temperature) type(hor_index_type), intent(in) :: HI !< Horizontal indices type(verticalGrid_type), pointer :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< OBC data structure, data intent(inout) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(param_file_type), intent(in) :: param_file !< Parameter file handle @@ -4922,25 +4923,31 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! Local variables type(vardesc) :: vd(2) integer :: m, n - character(len=100) :: mesg + character(len=100) :: mesg, var_name type(OBC_segment_type), pointer :: segment=>NULL() if (.not. associated(OBC)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& "uninitialized OBC control structure") - ! *** This is a temporary work around for restarts with OBC segments. + ! ### This is a temporary work around for restarts with OBC segments. ! This implementation uses 3D arrays solely for restarts. We need ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using - ! so much memory and disk space. *** + ! so much memory and disk space. if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') - vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), & - .false., restart_CS) + vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed instead: + ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, & + ! conversion=US%L_T_to_m_s) endif if (OBC%oblique_BCs_exist_globally) then @@ -4949,12 +4956,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart vd(1) = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') vd(2) = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), & - .false., restart_CS) + call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') - call register_restart_field(OBC%cff_normal, vd(1), .false., restart_CS) + call register_restart_field(OBC%cff_normal, "cff_normal", .false., restart_CS, & + longname="denominator for oblique OBCs", & + units="m2 s-2", conversion=US%L_T_to_m_s**2, hor_grid="q") endif if (Reg%ntr == 0) return @@ -4978,13 +4986,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') else - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') endif endif enddo @@ -4994,13 +5002,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') else - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') endif endif enddo diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 13af5a936a..1e818bd298 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1634,11 +1634,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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") + "Ice shelf mass", "kg m-2", conversion=US%RZ_to_kg_m2) call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") + "Ice shelf area in cell", "m2", conversion=US%L_to_m**2) call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") + "ice sheet/shelf thickness", "m", conversion=US%Z_to_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", & @@ -1646,7 +1646,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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) + .false., CS%restart_CSp, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1663,13 +1663,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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) + call register_ice_shelf_dyn_restarts(CS%Grid_in, US, 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") + ! "Friction velocity under ice shelves", "m s-1", conversion=###) !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1698,23 +1698,23 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%h_shelf(i,j) = Z_rescale * ISS%h_shelf(i,j) enddo ; enddo endif if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & - (US%m_to_Z*US%kg_m3_to_R /= US%m_to_Z_restart * US%kg_m3_to_R_restart)) then - RZ_rescale = US%m_to_Z*US%kg_m3_to_R / (US%m_to_Z_restart * US%kg_m3_to_R_restart) + (US%m_to_Z_restart*US%kg_m3_to_R_restart /= 1.0)) then + RZ_rescale = 1.0 / (US%m_to_Z_restart * US%kg_m3_to_R_restart) do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) enddo ; enddo endif - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) then + L_rescale = 1.0 / US%m_to_L_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fb674e36c..606ab49d8c 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -224,8 +224,9 @@ end function quad_area !> This subroutine is used to register any fields related to the ice shelf !! dynamics that should be written to or read from the restart file. -subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) +subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct @@ -275,20 +276,24 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%h_bdry_val(isd:ied,jsd:jed), source=0.0 ) ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & - "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & - "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_bdry_val, "u_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_bdry_val, "v_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_face_mask_bdry, "u_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%v_face_mask_bdry, "v_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & - "Average open ocean depth in a cell","m") + "Average open ocean depth in a cell", "m", conversion=US%Z_to_m) call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%C_basal_friction, "C_basal_friction", .true., restart_CS, & @@ -296,7 +301,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%AGlen_visc, "AGlen_visc", .true., restart_CS, & "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & - "ice thickness at the boundary","m") + "ice thickness at the boundary", "m", conversion=US%Z_to_m) endif end subroutine register_ice_shelf_dyn_restarts @@ -462,16 +467,16 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Take additional initialization steps, for example of dependent variables. if (active_shelf_dynamics .and. .not.new_sim) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%OD_av(i,j) = Z_rescale * CS%OD_av(i,j) enddo ; enddo endif if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & - (US%m_to_L_restart /= US%m_s_to_L_T*US%s_to_T_restart)) then - vel_rescale = US%m_s_to_L_T*US%s_to_T_restart / US%m_to_L_restart + (US%m_to_L_restart /= US%s_to_T_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7cc3c020a3..4e96bab8f5 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -309,7 +309,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< Ice-shelf thickness + intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -330,7 +330,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & "inflow ice velocity at upstream boundary", & - units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) + units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & "flux thickness at upstream boundary", & units="m", default=1000., scale=US%m_to_Z) @@ -409,7 +409,7 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + !! shelf is floating: 0 if floating, 1 if not. [nondim] ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -461,13 +461,14 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& floatfr_varname = "float_frac" - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, position=CORNER,scale=1.0) -! call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) + !### I think that the following two lines should have ..., scale=US%m_s_to_L_T + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=1.0) +! call MOM_read_data(filename, trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) + call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) - filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) + filename = trim(inputdir)//trim(bed_topo_file) + call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) ! isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -480,18 +481,19 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [L T-1 ~> m s-1]. real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: umask !< A mask foor ice shelf velocity + intent(inout) :: umask !< A mask for ice shelf velocity [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: vmask !< A mask foor ice shelf velocity + intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] !! boundary vertices [L T-1 ~> m s-1]. @@ -499,9 +501,9 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf [nondim] real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_shelf !< Ice-shelf thickness + intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -557,16 +559,17 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) - filename = trim(inputdir)//trim(icethick_file) + call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) + !### I think that the following two lines should have ..., scale=US%m_s_to_L_T + call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(vmask_varname), vmask, G%Domain, position=CORNER, scale=1.) + filename = trim(inputdir)//trim(icethick_file) ! call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) + call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec do j=jsc,jec diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 690345f988..a63a5f2e2d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -533,13 +533,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "MOM6 attempted to restart from a file from a different time than given by Time_in.") Time = Time_in endif - if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do k=1,nz ; do j=js,je ; do i=is,ie ; h(i,j,k) = H_rescale * h(i,j,k) ; enddo ; enddo ; enddo endif if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; u(I,j,k) = vel_rescale * u(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; v(i,J,k) = vel_rescale * v(i,J,k) ; enddo ; enddo ; enddo endif @@ -2778,7 +2778,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) >= 1.0) then + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then nPoints = nPoints + 1 tempAvg = tempAvg + tv%T(i,j,k) saltAvg = saltAvg + tv%S(i,j,k) @@ -2786,6 +2786,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. call sum_across_PEs(nPoints) call sum_across_PEs(tempAvg) call sum_across_PEs(saltAvg) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index af9534e943..5f38fa15d0 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -65,8 +65,8 @@ module MOM_oda_incupd !! registered by calls to set_up_oda_incupd_field type(p3d) :: Inc(MAX_FIELDS_) !< The increments to be applied to the field - type(p3d) :: Inc_u !< The increments to be applied to the u-velocities - type(p3d) :: Inc_v !< The increments to be applied to the v-velocities + type(p3d) :: Inc_u !< The increments to be applied to the u-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Inc_v !< The increments to be applied to the v-velocities, with data in [L T-1 ~> m s-1] type(p3d) :: Ref_h !< Vertical grid on which the increments are provided @@ -99,9 +99,6 @@ subroutine initialize_oda_incupd_fixed( G, GV, US, CS, restart_CS) !! structure for this module (in/out). type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=256) :: mesg if (associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd_fixed called with an associated "// & "control structure.") @@ -119,7 +116,7 @@ end subroutine initialize_oda_incupd_fixed !> This subroutine defined the number of time step for full update, stores the layer pressure !! increments and initialize remap structure. -subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, restart_CS) +subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -132,8 +129,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res !! [H ~> m or kg m-2]. type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct -! 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_oda" ! This module's name. logical :: use_oda_incupd logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries @@ -231,6 +228,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data CS%Ref_h%p(i,j,k) = data_h(i,j,k) enddo; enddo ; enddo + !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & @@ -329,16 +327,17 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid - real, allocatable, dimension(:,:,:) :: h_obs !< h of increments - real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_obs !< Layer-thicknesses of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] character(len=256) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -527,23 +526,24 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t inc. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s inc. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u inc. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v inc. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t increments [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u increments [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v increments [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: h_obs !< h of increments real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB ! integer :: ncount ! time step counter - real :: inc_wt ! weight of the update for this time-step - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's + real :: inc_wt ! weight of the update for this time-step [nondim] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] character(len=256) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -735,7 +735,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) deallocate(tmp_h,tmp_val2,hu_obs,hv_obs) deallocate(h_obs) - end subroutine apply_oda_incupd +end subroutine apply_oda_incupd !> Output increment if using full fields for the oda_incupd module. subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) @@ -771,12 +771,12 @@ subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) call register_restart_field(CS%Inc(2)%p, "S_inc", .true., restart_CSp_tmp, & "Salinity increment", "psu") call register_restart_field(CS%Ref_h%p, "h_obs", .true., restart_CSp_tmp, & - "Observational h", "m") + "Observational h", units=get_thickness_units(GV), conversion=GV%H_to_MKS) if (CS%uv_inc) then u_desc = var_desc("u_inc", "m s-1", "U-vel increment", hor_grid='Cu') v_desc = var_desc("v_inc", "m s-1", "V-vel increment", hor_grid='Cv') call register_restart_pair(CS%Inc_u%p, CS%Inc_v%p, u_desc, v_desc, & - .false., restart_CSp_tmp) + .false., restart_CSp_tmp, conversion=US%L_T_to_m_s) endif ! get the name of the output file diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c786f395cf..80054ffff9 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -14,7 +14,6 @@ module MOM_MEKE use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type @@ -1326,16 +1325,16 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) ! Account for possible changes in dimensional scaling for variables that have been ! read from a restart file. I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T + if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & + I_T_rescale = US%s_to_T_restart L_rescale = 1.0 - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) & - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) & + L_rescale = 1.0 / US%m_to_L_restart if (L_rescale*I_T_rescale /= 1.0) then if (allocated(MEKE%MEKE)) then ; if (query_initialized(MEKE%MEKE, "MEKE_MEKE", restart_CS)) then do j=js,je ; do i=is,ie - MEKE%MEKE(i,j) = L_rescale*I_T_rescale * MEKE%MEKE(i,j) + MEKE%MEKE(i,j) = (L_rescale*I_T_rescale)**2 * MEKE%MEKE(i,j) enddo ; enddo endif ; endif endif @@ -1380,15 +1379,17 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) end function MEKE_init !> Allocates memory and register restart fields for the MOM_MEKE module. -subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) +subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! Local variables - type(vardesc) :: vd - real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff, MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au + + ! Local variables + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] logical :: Use_KH_in_MEKE logical :: useMEKE integer :: isd, ied, jsd, jed @@ -1397,13 +1398,13 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) useMEKE = .false.; call read_param(param_file,"USE_MEKE",useMEKE) ! Read these parameters to determine what should be in the restarts - MEKE_GMcoeff =-1.; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) - MEKE_FrCoeff =-1.; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) - MEKE_GMEcoeff =-1.; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) - MEKE_KhCoeff =1.; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) - MEKE_viscCoeff_Ku =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) - MEKE_viscCoeff_Au =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) - Use_KH_in_MEKE = .false.; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + MEKE_GMcoeff = -1. ; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) + MEKE_FrCoeff = -1. ; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) + MEKE_GMEcoeff = -1. ; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) + MEKE_KhCoeff = 1. ; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) + MEKE_viscCoeff_Ku = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) + MEKE_viscCoeff_Au = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) + Use_KH_in_MEKE = .false. ; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) if (.not. useMEKE) return @@ -1411,38 +1412,38 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) call MOM_mesg("MEKE_alloc_register_restart: allocating and registering", 5) isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed allocate(MEKE%MEKE(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE", "m2 s-2", hor_grid='h', z_grid='1', & - longname="Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%MEKE, vd, .false., restart_CS) + call register_restart_field(MEKE%MEKE, "MEKE", .false., restart_CS, & + longname="Mesoscale Eddy Kinetic Energy", units="m2 s-2", conversion=US%L_T_to_m_s**2) + if (MEKE_GMcoeff>=0.) allocate(MEKE%GM_src(isd:ied,jsd:jed), source=0.0) if (MEKE_FrCoeff>=0. .or. MEKE_GMECoeff>=0.) & allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) if (MEKE_KhCoeff>=0.) then allocate(MEKE%Kh(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Kh", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Kh, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh, "MEKE_Kh", .false., restart_CS, & + longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif allocate(MEKE%Rd_dx_h(isd:ied,jsd:jed), source=0.0) if (MEKE_viscCoeff_Ku/=0.) then allocate(MEKE%Ku(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Ku", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Ku, vd, .false., restart_CS) + call register_restart_field(MEKE%Ku, "MEKE_Ku", .false., restart_CS, & + longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif if (Use_Kh_in_MEKE) then allocate(MEKE%Kh_diff(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Kh_diff", "m2 s-1",hor_grid='h',z_grid='1', & - longname="Copy of thickness diffusivity for diffusing MEKE") - call register_restart_field(MEKE%Kh_diff, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & + longname="Copy of thickness diffusivity for diffusing MEKE", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif if (MEKE_viscCoeff_Au/=0.) then allocate(MEKE%Au(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Au", "m4 s-1", hor_grid='h', z_grid='1', & - longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Au, vd, .false., restart_CS) + call register_restart_field(MEKE%Au, "MEKE_Au", .false., restart_CS, & + longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy", & + units="m4 s-1", conversion=US%L_to_m**4*US%s_to_T) endif end subroutine MEKE_alloc_register_restart diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dfbb3e0d63..7045a1a52c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,7 +16,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists +use MOM_io, only : slasher, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -2086,7 +2086,6 @@ end subroutine PPM_limit_pos ! ! This subroutine is used to allocate and register any fields in this module ! ! that should be written to or read from the restart file. ! logical :: use_int_tides -! type(vardesc) :: vd ! integer :: num_freq, num_angle , num_mode, period_1 ! integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, a ! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2108,10 +2107,9 @@ end subroutine PPM_limit_pos ! call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) ! allocate(CS%En_restart(isd:ied, jsd:jed, num_angle), source=0.0) -! vd = vardesc("En_restart", & -! "The internal wave energy density as a function of (i,j,angle,frequency,mode)", & -! 'h','1','1',"J m-2") -! call register_restart_field(CS%En_restart, vd, .false., restart_CS) +! call register_restart_field(CS%En_restart, "En_restart", .false., restart_CS, & +! longname="The internal wave energy density as a function of (i,j,angle,frequency,mode)", & +! units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1') ! end subroutine register_int_tide_restarts diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 6176f4aa1d..d8da752a1f 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -13,12 +13,11 @@ module MOM_mixed_layer_restrat use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -922,8 +921,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! Rescale variables from restart files if the internal dimensional scalings have changed. if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%MLD_filtered(i,j) = H_rescale * CS%MLD_filtered(i,j) enddo ; enddo @@ -931,8 +930,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, endif if (CS%MLE_MLD_decay_time2>0.) then if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%MLD_filtered_slow(i,j) = H_rescale * CS%MLD_filtered_slow(i,j) enddo ; enddo @@ -945,14 +944,15 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, end function mixedlayer_restrat_init !> Allocate and register fields in the mixed layer restratification structure for restarts -subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) +subroutine mixedlayer_restrat_register_restarts(HI, GV, param_file, CS, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + ! Local variables - type(vardesc) :: vd logical :: mixedlayer_restrat_init ! Check to see if this module will be used @@ -967,16 +967,16 @@ subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then ! CS%MLD_filtered is used to keep a running mean of the PBL's actively mixed MLD. allocate(CS%MLD_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered","m","Time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered", .false., restart_CS, & + longname="Time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif if (CS%MLE_MLD_decay_time2>0.) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered_slow","m","c Slower time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered_slow, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered_slow", .false., restart_CS, & + longname="Slower time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif end subroutine mixedlayer_restrat_register_restarts diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index fb969953c4..92e7b44128 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1807,9 +1807,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) end subroutine set_viscous_ML !> Register any fields associated with the vertvisc_type. -subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) +subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(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(vertvisc_type), intent(inout) :: visc !< A structure containing vertical @@ -1849,20 +1850,22 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & - "Shear-driven turbulent diffusivity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent diffusivity at interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & - "Shear-driven turbulent viscosity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent viscosity at interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & - "Shear-driven turbulent viscosity at vertex interfaces", "m2 s-1", & - hor_grid="Bu", z_grid='i') + "Shear-driven turbulent viscosity at vertex interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -1882,7 +1885,7 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) if (MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & - "Instantaneous active mixing layer depth", "m") + "Instantaneous active mixing layer depth", "m", conversion=US%Z_to_m) endif if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then @@ -2191,9 +2194,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed), source=0.0) allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB), source=0.0) CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', & - diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'm') + diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'nondim') CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', & - diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') + diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'nondim') endif call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) @@ -2202,11 +2205,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! Account for possible changes in dimensional scaling for variables that have been ! read from a restart file. Z_rescale = 1.0 - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) & - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if (US%m_to_Z_restart /= 0.0) Z_rescale = 1.0 / US%m_to_Z_restart I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T + if (US%s_to_T_restart /= 0.0) I_T_rescale = US%s_to_T_restart Z2_T_rescale = Z_rescale**2*I_T_rescale if (Z2_T_rescale /= 1.0) then diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 44423b5650..f85623bbd1 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -138,7 +138,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re rem_time_ptr => CS%remaining_source_time call register_restart_field(rem_time_ptr, "bir_remain_time", & .not.CS%tracers_may_reinit, restart_CS, & - "Remaining time to apply BIR source", "s") + "Remaining time to apply BIR source", "s", conversion=US%T_to_s) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -196,8 +196,8 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, endif enddo ! Tracer loop - if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T /= US%s_to_T_restart) ) then - CS%remaining_source_time = (US%s_to_T / US%s_to_T_restart) * CS%remaining_source_time + if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0) ) then + CS%remaining_source_time = (1.0 / US%s_to_T_restart) * CS%remaining_source_time endif if (associated(OBC)) then diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index d136d58a19..7583485ad7 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -427,8 +427,9 @@ function periodic_real(rval, num_period) result(val_out) !> This subroutine is used to allocate and register any fields in this module !! that should be written to or read from the restart file. -subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) +subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. @@ -469,9 +470,11 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) allocate(CS%precip_0(isd:ied,jsd:jed), source=0.0) call register_restart_field(CS%heat_0, "Ctrl_heat", .false., restart_CS, & - longname="Control Integrative Heating", units="W m-2", z_grid='1') + longname="Control Integrative Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1') call register_restart_field(CS%precip_0, "Ctrl_precip", .false., restart_CS, & - longname="Control Integrative Precipitation", units="kg m-2 s-1", z_grid='1') + longname="Control Integrative Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1') endif if (CS%num_cycle > 0) then @@ -485,13 +488,16 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) period_str = trim('p ')//trim(adjustl(period_str)) call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, & - longname="Cyclical Control Heating", units="W m-2", z_grid='1', t_grid=period_str) + longname="Cyclical Control Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1', t_grid=period_str) call register_restart_field(CS%precip_cyc, "Ctrl_precip_cycle", .false., restart_CS, & - longname="Cyclical Control Precipitation", units="kg m-2 s-1", z_grid='1', t_grid=period_str) + longname="Cyclical Control Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_time, "avg_time", .false., restart_CS, & - longname="Cyclical accumulated averaging time", units="sec", z_grid='1', t_grid=period_str) + longname="Cyclical accumulated averaging time", & + units="sec", conversion=US%T_to_s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SST_anom, "avg_SST_anom", .false., restart_CS, & - longname="Cyclical average SST Anomaly", units="deg C", z_grid='1', t_grid=period_str) + longname="Cyclical average SST Anomaly", units="degC", z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SSS_anom, "avg_SSS_anom", .false., restart_CS, & longname="Cyclical average SSS Anomaly", units="g kg-1", z_grid='1', t_grid=period_str) endif @@ -592,11 +598,9 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) ! Rescale if there are differences between the dimensional scaling of variables in ! restart files from those in use for this run. if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart*US%s_to_T_restart /= 0.0) .and. & - ((US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then + (US%s_to_T_restart /= US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then ! Redo the scaling of the corrective heat fluxes to [Q R Z T-1 ~> W m-2] - QRZ_T_rescale = (US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) + QRZ_T_rescale = US%s_to_T_restart / (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) if (associated(CS%heat_0)) then do j=jsc,jec ; do i=isc,iec @@ -612,11 +616,9 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) endif if ((US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T_restart /= 0.0) .and. & - ((US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then + (US%s_to_T_restart /= US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then ! Redo the scaling of the corrective precipitation to [R Z T-1 ~> kg m-2 s-1] - RZ_T_rescale = (US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) + RZ_T_rescale = US%s_to_T_restart / (US%kg_m3_to_R_restart * US%m_to_Z_restart) if (associated(CS%precip_0)) then do j=jsc,jec ; do i=isc,iec @@ -632,10 +634,10 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) endif if ((CS%num_cycle > 0) .and. associated(CS%avg_time) .and. & - ((US%s_to_T_restart /= 0.0) .and. ((US%s_to_T_restart) /= US%s_to_T)) ) then + ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) ) then ! Redo the scaling of the accumulated times to [T ~> s] do m=1,CS%num_cycle - CS%avg_time(m) = (US%s_to_T / US%s_to_T_restart) * CS%avg_time(m) + CS%avg_time(m) = (1.0 / US%s_to_T_restart) * CS%avg_time(m) enddo endif From 115d71477ddd491955467a0edd9116dc3bd04a78 Mon Sep 17 00:00:00 2001 From: OlgaSergienko <39838355+OlgaSergienko@users.noreply.github.com> Date: Tue, 22 Mar 2022 10:12:44 -0400 Subject: [PATCH 067/155] Ice dynamics (#80) * In MOM_ice_shelf_dynamics.F90 changes are made to calc_shelf_visc() and calc_shelf_driving_stress() to account for an irregular quadrilateral grid. In MOM_ice_shelf_initialize.F90 changes are made to initialize_ice_thickness_from_file() to correct masks at initialization. * Changed indentation * Changes are made to 'calc_shelf_visc()` to make computations of the velocity derivatives rotation-invariant. Changes in `update_ice_shelf()` utilize G%IareaT(:,:) instead of 1/G%areaT(:,:). * Allocate shelf_sfc_mass_flux for dynamic ice shelf configurations * Conditional allocation of ice shelf fluxes and data override call for sfc mass flux * get rid of excessive line length * call data override init for ice shelves * A new subroutine change_thickness_using_precip() changes the ice thickness in response to the atmospheric mass flux * Conditional calls to data_override - Introduces a new flag: DATA_OVERRIDE_SHELF_FLUXES, which if set to True, and ACTIVE_SHELF_DYNAMICS is also True, will enable data_override capability for the surface mass deposition (only avaialble for MOSAIC grid types) * Changes are made to extrapolate_metric() in MOM_grid_initialize.F90 to avoid negative values at the southern boundary of the domain. This is done for grids extending over Antarctica. * Reversed changes in MOM_grid_initialize.F90 to debug a regression test. * Uncommented lines reading the ice velocity from file * Changes to scaling factors and conversions of the 'sfc_mass_flux' parameter * Remove unnecessary diagnostics for ice shelves from MOM_forcing_type * Correct rescaling for data override of ice shelf sfc mass fluxes * Add diagnostic rescaling for ice shelf mass fluxes * Uncommented assignement of 'area_shelf_h(i,j)=G%areaT(i,j)' in MOM_ice_shelf_initialize.F90 and modified the four halo updates in MOM_ice_shelf.F90. Co-authored-by: Matthew Harrison --- config_src/drivers/solo_driver/MOM_driver.F90 | 6 ++ src/core/MOM_forcing_type.F90 | 33 ++++++- src/ice_shelf/MOM_ice_shelf.F90 | 94 ++++++++++++++++++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 18 +++- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 14 +-- 5 files changed, 139 insertions(+), 26 deletions(-) diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 1b88f1ce36..c2cd0a248c 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -26,6 +26,7 @@ program MOM_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_data_override, only : data_override_init use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end @@ -47,6 +48,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_ice_shelf, only : ice_shelf_query use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -176,6 +178,8 @@ program MOM_main type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, + !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() type(MOM_restart_CS), pointer :: & restart_CSp => NULL() !< A pointer to the restart control structure @@ -302,6 +306,8 @@ program MOM_main ! when using an ice shelf call initialize_ice_shelf_fluxes(ice_shelf_CSp, grid, US, fluxes) call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) + call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) + if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index be40f7bcb7..23b8b9da7c 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,6 +170,8 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux + !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] @@ -377,7 +379,6 @@ module MOM_forcing_type ! Iceberg + Ice shelf diagnostic handles integer :: id_ustar_ice_cover = -1 integer :: id_frac_ice_cover = -1 - ! wave forcing diagnostics handles. integer :: id_lamult = -1 !>@} @@ -2099,6 +2100,12 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%iceshelf_melt(i,j) = flux_tmp%iceshelf_melt(i,j) enddo ; enddo endif + if (associated(fluxes%shelf_sfc_mass_flux) & + .and. associated(flux_tmp%shelf_sfc_mass_flux)) then + do i=isd,ied ; do j=jsd,jed + fluxes%shelf_sfc_mass_flux(i,j) = flux_tmp%shelf_sfc_mass_flux(i,j) + enddo ; enddo + endif if (associated(fluxes%frac_shelf_h) .and. associated(flux_tmp%frac_shelf_h)) then do i=isd,ied ; do j=jsd,jed fluxes%frac_shelf_h(i,j) = flux_tmp%frac_shelf_h(i,j) @@ -2928,7 +2935,8 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & - shelf, iceberg, salt, fix_accum_bug, cfc, waves) + shelf, iceberg, salt, fix_accum_bug, cfc, waves, & + shelf_sfc_accumulation) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -2942,14 +2950,21 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & !! accumulation of ustar_gustless logical, optional, intent(in) :: cfc !< If present and true, allocate cfc fluxes logical, optional, intent(in) :: waves !< If present and true, allocate wave fields + logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, + !! then allocate surface flux deposition from the atmosphere + !! over ice shelves and ice sheets. ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB logical :: heat_water + logical :: shelf_sfc_acc isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + shelf_sfc_acc=.false. + if (present(shelf_sfc_accumulation)) shelf_sfc_acc=shelf_sfc_accumulation + call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) @@ -2987,9 +3002,13 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%p_surf,isd,ied,jsd,jed, press) - call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + ! These fields should only be allocated if ice shelf is enabled. + if (present(shelf)) then; if (shelf) then + call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc) + endif; endif !These fields should only on allocated when iceberg area is being passed through the coupler. call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg) @@ -3257,6 +3276,8 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) if (associated(fluxes%ustar_shelf)) deallocate(fluxes%ustar_shelf) if (associated(fluxes%iceshelf_melt)) deallocate(fluxes%iceshelf_melt) + if (associated(fluxes%shelf_sfc_mass_flux)) & + deallocate(fluxes%shelf_sfc_mass_flux) if (associated(fluxes%frac_shelf_h)) deallocate(fluxes%frac_shelf_h) if (associated(fluxes%ustar_berg)) deallocate(fluxes%ustar_berg) if (associated(fluxes%area_berg)) deallocate(fluxes%area_berg) @@ -3355,6 +3376,7 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%frac_shelf_h, turns, fluxes%frac_shelf_h) call rotate_array(fluxes_in%ustar_shelf, turns, fluxes%ustar_shelf) call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + call rotate_array(fluxes_in%shelf_sfc_mass_flux, turns, fluxes%shelf_sfc_mass_flux) endif if (do_iceberg) then @@ -3603,6 +3625,7 @@ subroutine homogenize_forcing(fluxes, G, GV, US) call homogenize_field_t(fluxes%frac_shelf_h, G) call homogenize_field_t(fluxes%ustar_shelf, G, tmp_scale=US%Z_to_m*US%s_to_T) call homogenize_field_t(fluxes%iceshelf_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%shelf_sfc_mass_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) endif if (do_iceberg) then diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 13af5a936a..c1e5392d5e 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_data_override, only : data_override use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl 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 @@ -160,6 +161,8 @@ module MOM_ice_shelf !! equation of state to use. logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result !! the dynamic ice-shelf model. + logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be + !! written using the data_override feature (only for MOSAIC grids) logical :: override_shelf_movement !< If true, user code specifies the shelf movement !! instead of using the dynamic ice-shelf mode. logical :: isthermo !< True if the ice shelf can exchange heat and @@ -188,7 +191,8 @@ module MOM_ice_shelf id_h_shelf = -1, id_h_mask = -1, & id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & - id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1 + id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & + id_shelf_sfc_mass_flux = -1 !>@} integer :: id_read_mass !< An integer handle used in time interpolation of @@ -321,6 +325,11 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) G => CS%grid ; US => CS%US ISS => CS%ISS + if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & + scale=US%kg_m2s_to_RZ_T) + endif + if (CS%rotate_index) then allocate(sfc_state) call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state, CS%Grid, CS%turns) @@ -730,6 +739,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & scale=US%RZ_to_kg_m2) endif + + call change_thickness_using_precip(CS, ISS, G, US, fluxes,US%s_to_T*time_step, Time) + + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + endif if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) @@ -753,6 +771,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_shelf_sfc_mass_flux > 0) call post_data(CS%id_shelf_sfc_mass_flux, fluxes%shelf_sfc_mass_flux, CS%diag) + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (sfc_state%sst-ISS%tfreeze), CS%diag) if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) @@ -1265,7 +1285,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) + !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) @@ -1354,6 +1374,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) CS%active_shelf_dynamics = .not.CS%override_shelf_movement + call get_param(param_file, mdl, "DATA_OVERRIDE_SHELF_FLUXES", & + CS%data_override_shelf_fluxes, & + "If true, the data override feature is used to write "//& + "the surface mass flux deposition. This option is only "//& + "available for MOSAIC grid types.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) @@ -1815,6 +1840,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%active_shelf_dynamics) then CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, & 'ice shelf thickness mask', 'none') + CS%id_shelf_sfc_mass_flux = register_diag_field('ice_shelf_model', 'sfc_mass_flux', CS%diag%axesT1, CS%Time, & + 'ice shelf surface mass flux deposition from atmosphere', 'none', conversion=US%RZ_T_to_kg_m2s) endif call MOM_IS_diag_mediator_close_registration(CS%diag) @@ -1845,7 +1872,7 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo) + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation = CS%active_shelf_dynamics) 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.) @@ -1975,6 +2002,57 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) end select end subroutine initialize_shelf_mass +!> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf. +!>>acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate +!>>positive for accumulation negative for ablation +subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes,time_step, Time) + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that + !! includes surface mass flux + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + + ! locals + integer :: i, j + real ::I_rho_ice + + I_rho_ice = 1.0 / CS%density_ice + + !update time +! CS%Time = Time + + +! CS%time_step = time_step + ! update surface mass flux rate +! if (CS%surf_mass_flux_from_file) call update_surf_mass_flux(G, US, CS, ISS, Time) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice + else + ! the ice is about to ablate, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + endif + enddo ; enddo + + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) + +end subroutine change_thickness_using_precip + !> Updates the ice shelf mass using data from a file. subroutine update_shelf_mass(G, US, CS, ISS, Time) @@ -2032,12 +2110,13 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) end subroutine update_shelf_mass !> Save the ice shelf restart file -subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf) +subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nodim]. real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] - + logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using + !! the data_override capability (only for MOSAIC grids) integer :: i, j @@ -2055,6 +2134,11 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf) enddo ; enddo endif + if (present(data_override_shelf_fluxes)) then + data_override_shelf_fluxes=.false. + if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes + endif + end subroutine ice_shelf_query !> Save the ice shelf restart file diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fb674e36c..5eccf92976 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -895,7 +895,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) -! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) + call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -1816,13 +1816,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed iegq = G%iegB ; jegq = G%jegB ! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 @@ -1842,6 +1843,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then @@ -1851,6 +1853,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif enddo enddo + + call pass_var(S, G%domain) + allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + do j=jscq,jecq ; do i=iscq,iecq + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) + enddo ; enddo + do j=jsc-1,jec+1 do i=isc-1,iec+1 cnt = 0 @@ -1996,6 +2005,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif enddo enddo + + deallocate(Phi) end subroutine calc_shelf_driving_stress subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) @@ -2592,7 +2603,8 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - do j=jsc,jec ; do i=isc,iec +! do j=jsc,jec ; do i=isc,iec + do j=jscq,jecq ; do i=iscq,iecq call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7cc3c020a3..751a6953e6 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -395,8 +395,6 @@ end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file -!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& -! hmask,h_shelf, G, US, PF) subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -410,12 +408,6 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: h_shelf !< A mask indicating which tracer points are -! !! partly or fully covered by an ice-shelf type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -508,7 +500,7 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & - h_varname,hmsk_varname ! Variable name in file + hmsk_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec @@ -526,9 +518,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & "The file from which the ice-shelf thickness is read.", & default="ice_shelf_thick.nc") -! call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", h_varname, & -! "The name of the thickness variable in ICE_THICKNESS_FILE.", & -! default="h_shelf") call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & default="h_mask") @@ -565,7 +554,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) filename = trim(inputdir)//trim(icethick_file) -! call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec From ce22d7aea20d9cfb2aefa8781adee60b81bcafd4 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Sat, 12 Mar 2022 20:35:11 -0500 Subject: [PATCH 068/155] add missing shared variable --- src/diagnostics/MOM_wave_speed.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 6765f9aa12..0f3b19f2e1 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -759,7 +759,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP c1_thresh,tol_solve,tol_merge) + !$OMP c1_thresh,tol_solve,tol_merge,c2_scale) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can From 8bf9abbad18840939b8858c3ab767d8420c1724f Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Wed, 23 Mar 2022 16:22:58 -0400 Subject: [PATCH 069/155] reworked algebra corner spread, rotation parenthesis (#90) * reworked algebra corner spread, rotation parenthesis * replace .lt. by < Co-authored-by: Raphael Dussin --- .../lateral/MOM_internal_tides.F90 | 209 ++++++++++-------- 1 file changed, 114 insertions(+), 95 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dfbb3e0d63..6c276fe8d0 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -545,8 +545,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & tot_Froude_loss(i,j) = tot_Froude_loss(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) enddo ; enddo ; enddo ; enddo ; enddo do j=js,je ; do i=is,ie - tot_allprocesses_loss(i,j) = tot_leak_loss(i,j) + tot_quad_loss(i,j) + & - tot_itidal_loss(i,j) + tot_Froude_loss(i,j) + tot_allprocesses_loss(i,j) = ((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & + (tot_itidal_loss(i,j) + tot_Froude_loss(i,j))) enddo ; enddo CS%tot_leak_loss = tot_leak_loss CS%tot_quad_loss = tot_quad_loss @@ -577,8 +577,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & - CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m) + & - CS%TKE_itidal_loss(i,j,a,fr,m) + CS%TKE_Froude_loss(i,j,a,fr,m) + ((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & + (CS%TKE_itidal_loss(i,j,a,fr,m) + CS%TKE_Froude_loss(i,j,a,fr,m))) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) @@ -1056,7 +1056,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) speed(:,:) = 0.0 do J=jsh-1,jeh ; do I=ish-1,ieh f2 = G%CoriolisBu(I,J)**2 - speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & + speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo do a=1,na @@ -1178,7 +1178,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS do j=jsh,jeh ; do i=ish,ieh do m=1,int(Nsubrays) - theta = energized_angle - 0.5*Angle_size + real(m - 1)*Angle_size*I_Nsubwedges + theta = (energized_angle - 0.5*Angle_size) + real(m - 1)*Angle_size*I_Nsubwedges if (theta < 0.0) then theta = theta + TwoPi elseif (theta > TwoPi) then @@ -1268,114 +1268,133 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS if (0.0 <= theta .and. theta < 0.25*TwoPi) then xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) ! west area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aW = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! southwest area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aSW = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aSW = a1 + a2 + a3 + a4 + aSW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! south area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aS = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! area within cell - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aC = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then xCrn = x(I,J-1); yCrn = y(I,J-1) ! south area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aS = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! southeast area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aSE = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aSE = a1 + a2 + a3 + a4 + aSE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! east area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aE = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! area within cell - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aC = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then xCrn = x(I,J); yCrn = y(I,J) ! east area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aE = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! northeast area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aNE = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aNE = a1 + a2 + a3 + a4 + aNE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! north area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aN = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! area within cell - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aC = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then xCrn = x(I-1,J); yCrn = y(I-1,J) ! north area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aN = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! northwest area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aNW = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aNW = a1 + a2 + a3 + a4 + aNW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! west area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aW = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! area within cell - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aC = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) endif ! energy weighting ---------------------------------------- - a_total = aNE + aN + aNW + aW + aSW + aS + aSE + aE + aC - E_new(m) = (aNE*En(i+1,j+1) + aN*En(i,j+1) + aNW*En(i-1,j+1) + & - aW*En(i-1,j) + aSW*En(i-1,j-1) + aS*En(i,j-1) + & - aSE*En(i+1,j-1) + aE*En(i+1,j) + aC*En(i,j)) / (dx(i,j)*dy(i,j)) + a_total = (((aNE + aSW) + (aNW + aSE)) + ((aN + aS) + (aW + aE))) + aC + + E_new(m) = ( ( ( ( aNE*En(i+1,j+1) + aSW*En(i-1,j-1) ) + & + ( aNW*En(i-1,j+1) + aSE*En(i+1,j-1) ) ) + & + ( ( aN*En(i,j+1) + aS*En(i,j-1) ) + & + ( aW*En(i-1,j) + aE*En(i+1,j) ) ) ) + & + aC*En(i,j) ) / ( dx(i,j)*dy(i,j) ) enddo ! m-loop ! update energy in cell En(i,j) = sum(E_new)/Nsubrays @@ -1608,13 +1627,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) if (v(i) > 0.0) then if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif - curv_3 = hL(i,j) + hR(i,j) - 2.0*h(i,j) + curv_3 = (hL(i,j) + hR(i,j)) - 2.0*h(i,j) vh(i) = G%dx_Cv(i,J) * v(i) * ( hR(i,j) + CFL * & (0.5*(hL(i,j) - hR(i,j)) + curv_3*(CFL - 1.5)) ) elseif (v(i) < 0.0) then if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif - curv_3 = hL(i,j+1) + hR(i,j+1) - 2.0*h(i,j+1) + curv_3 = (hL(i,j+1) + hR(i,j+1)) - 2.0*h(i,j+1) vh(i) = G%dx_Cv(i,J) * v(i) * ( hL(i,j+1) + CFL * & (0.5*(hR(i,j+1)-hL(i,j+1)) + curv_3*(CFL - 1.5)) ) else @@ -1692,12 +1711,12 @@ subroutine reflect(En, NAngle, CS, G, LB) angle_wall0 = angle_wall - 1 ! compute relative angle from wall and use cyclic properties ! to ensure it is bounded by 0 -> Nangle-1 - angle_to_wall = mod(a0 - angle_wall0 + Nangle, Nangle) + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) if (ridge(i,j)) then ! if ray is not incident but in ridge cell, use complementary angle if ((Nangle_d2 < angle_to_wall) .and. (angle_to_wall < Nangle)) then - angle_wall0 = mod(angle_wall0 + Nangle_d2 + Nangle, Nangle) + angle_wall0 = mod(angle_wall0 + (Nangle_d2 + Nangle), Nangle) endif endif @@ -2057,7 +2076,7 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) do j=jis,jie ; do i=iis,iie ! This limiter prevents undershooting minima within the domain with ! values less than h_min. - curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j)) + curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j)) if (curv > 0.0) then ! Only minima are limited. dh = h_R(i,j) - h_L(i,j) if (abs(dh) < curv) then ! The parabola's minimum is within the cell. From 97331e705c680ea3c1b14d1a3cde8ada3f36115c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 13 Mar 2022 10:24:40 -0400 Subject: [PATCH 070/155] +Better multi-line parameter specification handling Added the ability to detect and handle multiline parameter specifications that are longer than INPUT_STR_LENGTH after the lines have been concatenated. Many instances where character strings are set to length INPUT_STR_LENGTH are replaced by param_file_type%max_line_len. This commit partially addresses MOM6 issue #75. All answers and output are bitwise identical in cases that worked previously, but there is a new element in the publicly visible param_file_type, and some cases where there had previously been errors due to very long input specification may now work. --- src/framework/MOM_file_parser.F90 | 107 +++++++++++++++++++++++++----- 1 file changed, 89 insertions(+), 18 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 3ad551496f..ed86e77bea 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -69,6 +69,9 @@ module MOM_file_parser logical :: log_to_stdout = log_to_stdout_default !< If true, all log !! messages are also sent to stdout. logical :: log_open = .false. !< True if the log file has been opened. + integer :: max_line_len = 4 !< The maximum number of characters in the lines + !! in any of the files in this param_file_type after + !! any continued lines have been combined. integer :: stdout !< The unit number from stdout(). integer :: stdlog !< The unit number from stdlog(). character(len=240) :: doc_file !< A file where all run-time parameters, their @@ -129,6 +132,7 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) logical :: file_exists, unit_in_use, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path + character(len=16) :: sub_string type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -196,6 +200,11 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) " has been opened successfully.", 5) call populate_param_data(iounit, filename, CS%param_data(i)) + ! Increment the maximum line length, but always report values in blocks of 4 characters. + CS%max_line_len = max(CS%max_line_len, 4 + 4*(max_input_line_length(CS, i) - 1) / 4) + write (sub_string, '(i4.4)') CS%max_line_len + call MOM_mesg("open_param_file: Maximum input line length determined to be "//& + trim(adjustl(sub_string))//" characters.", 5) call read_param(CS,"SEND_LOG_TO_STDOUT",CS%log_to_stdout) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) @@ -574,7 +583,7 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -606,7 +615,7 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -642,7 +651,7 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) !! by before it is returned. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -678,8 +687,8 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) !! by before it is returned. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) - logical :: found, defined + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then @@ -713,7 +722,7 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -737,7 +746,7 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1), loc_string + character(len=CS%max_line_len) :: value_string(1), loc_string logical :: found, defined integer :: i, i_out @@ -775,7 +784,7 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string, paramIsLogical=.true.) @@ -802,7 +811,7 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f !! later be logged in the same format. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) character(len=240) :: err_msg logical :: found, defined real :: real_time, time_unit @@ -861,7 +870,7 @@ end subroutine read_param_time !> This function removes single and double quotes from a character string function strip_quotes(val_str) character(len=*) :: val_str !< The character string to work on - character(len=INPUT_STR_LENGTH) :: strip_quotes + character(len=len(val_str)) :: strip_quotes ! Local variables integer :: i strip_quotes = val_str @@ -879,7 +888,69 @@ function strip_quotes(val_str) enddo end function strip_quotes -!> This subtoutine extracts the contents of lines in the param_file_type that refer to +!> This function returns the maximum number of characters in any input lines after they +!! have been combined by any line continuation. +function max_input_line_length(CS, pf_num) result(max_len) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + integer, optional, intent(in) :: pf_num !< If present, only work on a single file in the + !! param_file_type, or return 0 if this exceeds the + !! number of files in the param_file_type. + integer :: max_len !< The maximum number of characters in any input lines after they + !! have been combined by any line continuation. + + ! Local variables + character(len=FILENAME_LENGTH) :: filename + ! character(len=:), allocatable :: line + character :: last_char + integer :: ipf, ipf_s, ipf_e + integer :: last, last1, line_len, count, contBufSize + logical :: continuedLine + + max_len = 0 + ipf_s = 1 ; ipf_e = CS%nfiles + if (present(pf_num)) then + if (pf_num > CS%nfiles) return + ipf_s = pf_num ; ipf_e = pf_num + endif + + paramfile_loop: do ipf = ipf_s, ipf_e + filename = CS%filename(ipf) + contBufSize = 0 + continuedLine = .false. + + ! Scan through each line of the file + do count = 1, CS%param_data(ipf)%num_lines + ! line = CS%param_data(ipf)%line(count) + last = len_trim(CS%param_data(ipf)%line(count)) + last_char = " " + if (last > 0) last_char = CS%param_data(ipf)%line(count)(last:last) + ! Check if line ends in continuation character (either & or \) + ! Note achar(92) is a backslash + if (last_char == achar(92) .or. last_char == "&") then + contBufSize = contBufSize + last - 1 + continuedLine = .true. + if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & + call MOM_error(FATAL, "MOM_file_parser : the last line of the file ends in a"// & + " continuation character but there are no more lines to read. "// & + " Line: '"//trim(CS%param_data(ipf)%line(count)(:last))//"'"// & + " in file "//trim(filename)//".") + cycle ! cycle inorder to append the next line of the file + elseif (continuedLine) then + ! If we reached this point then this is the end of line continuation + line_len = contBufSize + last + contBufSize = 0 + continuedLine = .false. + else ! This is a simple line with no continuation. + line_len = last + endif + max_len = max(max_len, line_len) + enddo ! CS%param_data(ipf)%num_lines + enddo paramfile_loop + +end function max_input_line_length + +!> This subroutine extracts the contents of lines in the param_file_type that refer to !! a named parameter. The value_string that is returned must be interepreted in a way !! that depends on the type of this variable. subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) @@ -893,9 +964,9 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL !! that can be simply defined without parsing a value_string. ! Local variables - character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine - character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName - character(len=FILENAME_LENGTH) :: filename + character(len=CS%max_line_len) :: val_str, lname, origLine + character(len=CS%max_line_len) :: line, continuationBuffer, blockName + character(len=FILENAME_LENGTH) :: filename integer :: is, id, isd, isu, ise, iso, ipf integer :: last, last1, ival, oval, max_vals, count, contBufSize character(len=52) :: set @@ -907,7 +978,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL logical, parameter :: requireNamedClose = .false. integer, parameter :: verbose = 1 set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" - continuationBuffer = repeat(" ",INPUT_STR_LENGTH) + continuationBuffer = repeat(" ", CS%max_line_len) contBufSize = 0 variableKindIsLogical=.false. @@ -949,7 +1020,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! If we reached this point then this is the end of line continuation continuationBuffer(contBufSize+1:contBufSize+len_trim(line))=line(:last) line = continuationBuffer - continuationBuffer=repeat(" ",INPUT_STR_LENGTH) ! Clear for next use + continuationBuffer=repeat(" ",CS%max_line_len) ! Clear for next use contBufSize = 0 continuedLine = .false. last = len_trim(line) @@ -1173,8 +1244,8 @@ end subroutine get_variable_line !> Record that a line has been used to set a parameter subroutine flag_line_as_read(line_used, count) - logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read - integer, intent(in) :: count !< The parameter on this line number has been read + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read line_used(count) = .true. end subroutine flag_line_as_read From 3b5d2641a49a8589648bbac72da87e1ddb4b2cfc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Mar 2022 06:59:44 -0400 Subject: [PATCH 071/155] Support arbitrarily long parameter spec lines Make the lines of the param_file_type individually allocatable to support arbitrarily long input lines. This required the introduction of a new private type to hold the actual allocatable array, so the lines are now an array of this type. All answers are bitwise identical. --- src/framework/MOM_file_parser.F90 | 61 +++++++++++++++++++------------ 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index ed86e77bea..a2fe6ec7a8 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -32,11 +32,17 @@ module MOM_file_parser logical, parameter :: minimal_doc_default = .true. !>@} + +!> A simple type to allow lines in an array to be allocated with variable sizes. +type, private :: file_line_type ; private + character(len=:), allocatable :: line !< An allocatable line with content +end type file_line_type + !> The valid lines extracted from an input parameter file without comments type, private :: file_data_type ; private integer :: num_lines = 0 !< The number of lines in this type - character(len=INPUT_STR_LENGTH), pointer, dimension(:) :: line => NULL() !< The line content - logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read + type(file_line_type), allocatable, dimension(:) :: fln !< Lines with the input content. + logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read end type file_data_type !> A link in the list of variables that have already had override warnings issued @@ -264,7 +270,8 @@ subroutine close_param_file(CS, quiet_close, component) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo CS%log_open = .false. @@ -322,7 +329,7 @@ subroutine close_param_file(CS, quiet_close, component) num_unused = num_unused + 1 if (CS%report_unused) & call MOM_error(WARNING, "Unused line in "//trim(CS%filename(i))// & - " : "//trim(CS%param_data(i)%line(n))) + " : "//trim(CS%param_data(i)%fln(n)%line)) endif enddo endif @@ -333,7 +340,8 @@ subroutine close_param_file(CS, quiet_close, component) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo deallocate(CS%blockName) @@ -356,13 +364,11 @@ subroutine populate_param_data(iounit, filename, param_data) ! Local variables character(len=INPUT_STR_LENGTH) :: line - integer :: num_lines + character(len=INPUT_STR_LENGTH), allocatable, dimension(:) :: lines_in + integer :: n, num_lines logical :: inMultiLineComment ! Find the number of keyword lines in a parameter file - ! Allocate the space to hold the lines in param_data%line - ! Populate param_data%line with the keyword lines from parameter file - if (all_PEs_read .or. is_root_pe()) then ! rewind the parameter file rewind(iounit) @@ -386,7 +392,6 @@ subroutine populate_param_data(iounit, filename, param_data) call MOM_error(FATAL, 'MOM_file_parser : A C-style multi-line comment '// & '(/* ... */) was not closed before the end of '//trim(filename)) - ! allocate space to hold contents of the parameter file param_data%num_lines = num_lines endif ! (is_root_pe()) @@ -397,17 +402,15 @@ subroutine populate_param_data(iounit, filename, param_data) ! Set up the space for storing the actual lines. num_lines = param_data%num_lines - allocate (param_data%line(num_lines)) - allocate (param_data%line_used(num_lines)) - param_data%line(:) = ' ' - param_data%line_used(:) = .false. + allocate (lines_in(num_lines)) + lines_in(:) = ' ' ! Read the actual lines. if (all_PEs_read .or. is_root_pe()) then ! rewind the parameter file rewind(iounit) - ! Populate param_data%line + ! Populate param_data%fln%line num_lines = 0 do while(.true.) read(iounit, '(a)', end=18) line @@ -419,7 +422,7 @@ subroutine populate_param_data(iounit, filename, param_data) line = removeComments(line) line = simplifyWhiteSpace(line(:len_trim(line))) num_lines = num_lines + 1 - param_data%line(num_lines) = line + lines_in(num_lines) = line endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif @@ -431,10 +434,22 @@ subroutine populate_param_data(iounit, filename, param_data) // 'reading of '//trim(filename)) endif ! (is_root_pe()) - ! Broadcast the populated array param_data%line + ! Broadcast the populated array lines_in if (.not. all_PEs_read) then - call broadcast(param_data%line, INPUT_STR_LENGTH, root_pe()) + call broadcast(lines_in, INPUT_STR_LENGTH, root_pe()) endif + + ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln + allocate(param_data%fln(num_lines)) + allocate(param_data%line_used(num_lines)) + param_data%line_used(:) = .false. + ! Populate param_data%fln%line with the keyword lines from parameter file + do n=1,num_lines + param_data%fln(n)%line = lines_in(n) + enddo + + deallocate(lines_in) + end subroutine populate_param_data @@ -921,10 +936,10 @@ function max_input_line_length(CS, pf_num) result(max_len) ! Scan through each line of the file do count = 1, CS%param_data(ipf)%num_lines - ! line = CS%param_data(ipf)%line(count) - last = len_trim(CS%param_data(ipf)%line(count)) + ! line = CS%param_data(ipf)%fln(count)%line + last = len_trim(CS%param_data(ipf)%fln(count)%line) last_char = " " - if (last > 0) last_char = CS%param_data(ipf)%line(count)(last:last) + if (last > 0) last_char = CS%param_data(ipf)%fln(count)%line(last:last) ! Check if line ends in continuation character (either & or \) ! Note achar(92) is a backslash if (last_char == achar(92) .or. last_char == "&") then @@ -933,7 +948,7 @@ function max_input_line_length(CS, pf_num) result(max_len) if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & call MOM_error(FATAL, "MOM_file_parser : the last line of the file ends in a"// & " continuation character but there are no more lines to read. "// & - " Line: '"//trim(CS%param_data(ipf)%line(count)(:last))//"'"// & + " Line: '"//trim(CS%param_data(ipf)%fln(count)%line(:last))//"'"// & " in file "//trim(filename)//".") cycle ! cycle inorder to append the next line of the file elseif (continuedLine) then @@ -999,7 +1014,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! Scan through each line of the file do count = 1, CS%param_data(ipf)%num_lines - line = CS%param_data(ipf)%line(count) + line = CS%param_data(ipf)%fln(count)%line last = len_trim(line) last1 = max(1,last) From 4e94c5d6ac4a25ccd1f3587702c49ee7d61df771 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Mar 2022 23:05:00 -0400 Subject: [PATCH 072/155] Reduce the populate_param_data memory footprint Use a character buffer to minimize the memory footprint associated with reading the input parameters on root_PE and broadcasting it to all PEs. All answers are bitwise identical. --- src/framework/MOM_file_parser.F90 | 49 +++++++++++++++++++++++-------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index a2fe6ec7a8..738f842842 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -364,10 +364,14 @@ subroutine populate_param_data(iounit, filename, param_data) ! Local variables character(len=INPUT_STR_LENGTH) :: line - character(len=INPUT_STR_LENGTH), allocatable, dimension(:) :: lines_in - integer :: n, num_lines + character(len=1), allocatable, dimension(:) :: char_buf + integer, allocatable, dimension(:) :: line_len ! The trimmed length of each processed input line + integer :: n, num_lines, total_chars, ch, rsc, llen, int_buf(2) logical :: inMultiLineComment + character(len=80) :: frag1, frag2 + + ! Find the number of keyword lines in a parameter file if (all_PEs_read .or. is_root_pe()) then ! rewind the parameter file @@ -375,6 +379,7 @@ subroutine populate_param_data(iounit, filename, param_data) ! count the number of valid entries in the parameter file num_lines = 0 + total_chars = 0 inMultiLineComment = .false. do while(.true.) read(iounit, '(a)', end=8) line @@ -382,7 +387,12 @@ subroutine populate_param_data(iounit, filename, param_data) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. else - if (lastNonCommentNonBlank(line)>0) num_lines = num_lines + 1 + if (lastNonCommentNonBlank(line)>0) then + line = removeComments(line) + line = simplifyWhiteSpace(line(:len_trim(line))) + num_lines = num_lines + 1 + total_chars = total_chars + len_trim(line) + endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif enddo ! while (.true.) @@ -392,18 +402,22 @@ subroutine populate_param_data(iounit, filename, param_data) call MOM_error(FATAL, 'MOM_file_parser : A C-style multi-line comment '// & '(/* ... */) was not closed before the end of '//trim(filename)) - param_data%num_lines = num_lines + + int_buf(1) = num_lines + int_buf(2) = total_chars endif ! (is_root_pe()) ! Broadcast the number of valid entries in parameter file if (.not. all_PEs_read) then - call broadcast(param_data%num_lines, root_pe()) + call broadcast(int_buf, 2, root_pe()) + num_lines = int_buf(1) + total_chars = int_buf(2) endif ! Set up the space for storing the actual lines. - num_lines = param_data%num_lines - allocate (lines_in(num_lines)) - lines_in(:) = ' ' + param_data%num_lines = num_lines + allocate (line_len(num_lines), source=0) + allocate (char_buf(total_chars), source=" ") ! Read the actual lines. if (all_PEs_read .or. is_root_pe()) then @@ -412,6 +426,7 @@ subroutine populate_param_data(iounit, filename, param_data) ! Populate param_data%fln%line num_lines = 0 + rsc = 0 do while(.true.) read(iounit, '(a)', end=18) line line = replaceTabs(line) @@ -422,7 +437,10 @@ subroutine populate_param_data(iounit, filename, param_data) line = removeComments(line) line = simplifyWhiteSpace(line(:len_trim(line))) num_lines = num_lines + 1 - lines_in(num_lines) = line + llen = len_trim(line) + line_len(num_lines) = llen + do ch=1,llen ; char_buf(rsc+ch)(1:1) = line(ch:ch) ; enddo + rsc = rsc + llen endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif @@ -434,9 +452,10 @@ subroutine populate_param_data(iounit, filename, param_data) // 'reading of '//trim(filename)) endif ! (is_root_pe()) - ! Broadcast the populated array lines_in + ! Broadcast the populated arrays line_len and char_buf if (.not. all_PEs_read) then - call broadcast(lines_in, INPUT_STR_LENGTH, root_pe()) + call broadcast(line_len, num_lines, root_pe()) + call broadcast(char_buf(1:total_chars), 1, root_pe()) endif ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln @@ -444,11 +463,15 @@ subroutine populate_param_data(iounit, filename, param_data) allocate(param_data%line_used(num_lines)) param_data%line_used(:) = .false. ! Populate param_data%fln%line with the keyword lines from parameter file + rsc = 0 do n=1,num_lines - param_data%fln(n)%line = lines_in(n) + line(1:INPUT_STR_LENGTH) = " " + do ch=1,line_len(n) ; line(ch:ch) = char_buf(rsc+ch)(1:1) ; enddo + param_data%fln(n)%line = trim(line) + rsc = rsc + line_len(n) enddo - deallocate(lines_in) + deallocate(char_buf) ; deallocate(line_len) end subroutine populate_param_data From 2ac64b39c8d9cb98ec253a781c1bdb78f361c6b9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Mar 2022 10:03:41 -0400 Subject: [PATCH 073/155] Set INPUT_STR_LENGTH to 1024 Now that INPUT_STR_LENGTH is only used as the size of a single temporary character string, the maximum permitted line length can be increased to a larger value without unduly impacting the memory footprint of the model, so it has been increased to 1024. If this is not large enough, considering that MOM6 also supports line continuation, there is a bigger problem than this limit. Some message strings were also changed to be allocatable, while others have sizes that are set using param_file_type%max_line_len. Also eliminated the hard-coded internal parameter all_PEs_read, which had a note that it should have been eliminated in about 2010 (before MOM6 existed). All answers and output are bitwise identical. --- src/framework/MOM_file_parser.F90 | 90 +++++++++++++------------------ 1 file changed, 38 insertions(+), 52 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 738f842842..853d3c4de4 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -16,13 +16,14 @@ module MOM_file_parser implicit none ; private +! These are hard-coded limits that are used in the following code. They should be set +! generously enough not to impose any significant limitations. integer, parameter, public :: MAX_PARAM_FILES = 5 !< Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 320 !< Maximum line length in parameter file. -integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. +integer, parameter :: INPUT_STR_LENGTH = 1024 !< Maximum line length in parameter file. Lines that + !! are combined by ending in '\' or '&' can exceed + !! this limit after merging. +integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. -! The all_PEs_read option should be eliminated with post-riga shared code. -logical :: all_PEs_read = .false. !< If true, all PEs read the input files - !! TODO: Eliminate this parameter !>@{ Default values for parameters logical, parameter :: report_unused_default = .true. @@ -138,7 +139,6 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) logical :: file_exists, unit_in_use, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path - character(len=16) :: sub_string type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -183,11 +183,10 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (Netcdf_file) & call MOM_error(FATAL,"open_param_file: NetCDF files are not yet supported.") - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then open(newunit=iounit, file=trim(filename), access='SEQUENTIAL', & form='FORMATTED', action='READ', position='REWIND', iostat=ios) - if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"// & - trim(filename)//"'.") + if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"//trim(filename)//"'.") else iounit = 1 endif @@ -202,15 +201,11 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (associated(CS%blockName)) deallocate(CS%blockName) allocate(block) ; block%name = '' ; CS%blockName => block - call MOM_mesg("open_param_file: "// trim(filename)// & - " has been opened successfully.", 5) + call MOM_mesg("open_param_file: "// trim(filename)//" has been opened successfully.", 5) call populate_param_data(iounit, filename, CS%param_data(i)) ! Increment the maximum line length, but always report values in blocks of 4 characters. CS%max_line_len = max(CS%max_line_len, 4 + 4*(max_input_line_length(CS, i) - 1) / 4) - write (sub_string, '(i4.4)') CS%max_line_len - call MOM_mesg("open_param_file: Maximum input line length determined to be "//& - trim(adjustl(sub_string))//" characters.", 5) call read_param(CS,"SEND_LOG_TO_STDOUT",CS%log_to_stdout) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) @@ -264,7 +259,7 @@ subroutine close_param_file(CS, quiet_close, component) if (present(quiet_close)) then ; if (quiet_close) then do i = 1, CS%nfiles - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) + if (is_root_pe()) close(CS%iounit(i)) call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & " has been closed successfully.", 5) CS%iounit(i) = -1 @@ -334,9 +329,8 @@ subroutine close_param_file(CS, quiet_close, component) enddo endif - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) - call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & - " has been closed successfully.", 5) + if (is_root_pe()) close(CS%iounit(i)) + call MOM_mesg("close_param_file: "// trim(CS%filename(i))//" has been closed successfully.", 5) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. @@ -369,11 +363,8 @@ subroutine populate_param_data(iounit, filename, param_data) integer :: n, num_lines, total_chars, ch, rsc, llen, int_buf(2) logical :: inMultiLineComment - character(len=80) :: frag1, frag2 - - ! Find the number of keyword lines in a parameter file - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) @@ -408,11 +399,9 @@ subroutine populate_param_data(iounit, filename, param_data) endif ! (is_root_pe()) ! Broadcast the number of valid entries in parameter file - if (.not. all_PEs_read) then - call broadcast(int_buf, 2, root_pe()) - num_lines = int_buf(1) - total_chars = int_buf(2) - endif + call broadcast(int_buf, 2, root_pe()) + num_lines = int_buf(1) + total_chars = int_buf(2) ! Set up the space for storing the actual lines. param_data%num_lines = num_lines @@ -420,7 +409,7 @@ subroutine populate_param_data(iounit, filename, param_data) allocate (char_buf(total_chars), source=" ") ! Read the actual lines. - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) @@ -435,6 +424,10 @@ subroutine populate_param_data(iounit, filename, param_data) else if (lastNonCommentNonBlank(line)>0) then line = removeComments(line) + if ((len_trim(line) > 1000) .and. is_root_PE()) then + call MOM_error(WARNING, "MOM_file_parser: Consider using continuation to split up "//& + "the excessivley long parameter input line "//trim(line)) + endif line = simplifyWhiteSpace(line(:len_trim(line))) num_lines = num_lines + 1 llen = len_trim(line) @@ -453,10 +446,8 @@ subroutine populate_param_data(iounit, filename, param_data) endif ! (is_root_pe()) ! Broadcast the populated arrays line_len and char_buf - if (.not. all_PEs_read) then - call broadcast(line_len, num_lines, root_pe()) - call broadcast(char_buf(1:total_chars), 1, root_pe()) - endif + call broadcast(line_len, num_lines, root_pe()) + call broadcast(char_buf(1:total_chars), 1, root_pe()) ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln allocate(param_data%fln(num_lines)) @@ -767,8 +758,7 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) if (found) then value = trim(strip_quotes(value_string(1))) elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_char @@ -805,8 +795,7 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) endif do i=i_out,SIZE(value) ; value(i) = " " ; enddo elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_char_array @@ -829,8 +818,7 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) if (found) then value = defined elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_logical @@ -891,11 +879,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') else - call MOM_error(FATAL,'Variable '//trim(varname)// & - ' found but not set in input files.') + call MOM_error(FATAL, 'Variable '//trim(varname)//' found but not set in input files.') endif endif ; endif endif @@ -907,7 +893,7 @@ end subroutine read_param_time !> This function removes single and double quotes from a character string function strip_quotes(val_str) - character(len=*) :: val_str !< The character string to work on + character(len=*), intent(in) :: val_str !< The character string to work on character(len=len(val_str)) :: strip_quotes ! Local variables integer :: i @@ -939,7 +925,6 @@ function max_input_line_length(CS, pf_num) result(max_len) ! Local variables character(len=FILENAME_LENGTH) :: filename - ! character(len=:), allocatable :: line character :: last_char integer :: ipf, ipf_s, ipf_e integer :: last, last1, line_len, count, contBufSize @@ -1003,7 +988,8 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! Local variables character(len=CS%max_line_len) :: val_str, lname, origLine - character(len=CS%max_line_len) :: line, continuationBuffer, blockName + character(len=CS%max_line_len) :: line, continuationBuffer + character(len=240) :: blockName character(len=FILENAME_LENGTH) :: filename integer :: is, id, isd, isu, ise, iso, ipf integer :: last, last1, ival, oval, max_vals, count, contBufSize @@ -1407,7 +1393,7 @@ subroutine log_param_int_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=CS%max_line_len+120) :: mesg character(len=240) :: myunits write(mesg, '(" ",a," ",a,": ",A)') trim(modulename), trim(varname), trim(left_ints(value)) @@ -1549,16 +1535,16 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & 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=1024) :: mesg, myunits + character(len=:), allocatable :: mesg + character(len=240) :: myunits - write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(value) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(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) endif - myunits=" "; if (present(units)) write(myunits(1:1024),'(A)') trim(units) + myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1936,7 +1922,7 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & ! Local variables logical :: do_read, do_log integer :: i, len_tot, len_val - character(len=1024) :: cat_val + character(len=:), allocatable :: cat_val do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log @@ -1947,7 +1933,7 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & endif if (do_log) then - cat_val = trim(value(1)); len_tot = len_trim(value(1)) + cat_val = trim(value(1)) ; len_tot = len_trim(value(1)) do i=2,size(value) len_val = len_trim(value(i)) if ((len_val > 0) .and. (len_tot + len_val + 2 < 240)) then From 4c5e98e1b1a715d7ad83772dfa28aa26f4a18666 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Mar 2022 16:21:59 -0400 Subject: [PATCH 074/155] Error handler support This patch introduces some limited support for error handling in a POSIX environment. A partial interface to the POSIX system calls is included as part of the implementation of this feature. An internal global logical flag, `ignore_fatal` is added to the `MOM_error_handler` module which controls the behavior of `FATAL` errors. If true, then `FATAL` errors trigger a signal (here `SIGUSR1`) which call a handler which restores the program to the earlier state. This change allows us to test `FATAL` errors at runtime without stopping program execution, so that we can cycle through multiple errors. This feature is toggled with two new functions, `disable_fatal_errors()` and `enable_fatal_errors()`. This is implemented in part using POSIX system calls from the C standard library (libc), using the C interoperability layer. Details which are unspecified by the POSIX standard, such as the definitions of signals or the datatype size, are defined in a header (`posix.h`) which can be optionally configured at compile-time. The header defaults to use typical Linux POSIX values, and may be configured by autoconf for more exotic platforms in a later patch. The previous state is set and restored by the `setjmp`/`longjmp` (or `sigsetjmp`/`siglongjmp`) functions. Although these functions behave as expected on all tested platforms, a code which uses these functions is not standards-conforming. If issues arise in the future, error handling may not be available on those platforms, and compile-time configuration may be required to disable these features. No existing code is using these features, but are expected to be part of a future patch. Error handler API: * `disable_fatal_errors` * `enable_fatal_errors` New POSIX API: * `chmod` * `signal` * `kill` * `getpid` * `getppid` * `sleep` * `setjmp` * `sigsetjmp` * `longjmp` * `siglongjmp` New derived types: * `jmp_buf` * `sigjmp_buf` New interface (for signal handlers): * `handler_interface` New compile-time macros: * `JMP_BUF_SIZE` * `SIGJMP_BUF_SIZE` * `SIGSETJMP_NAME` * `POSIX_SIGUSR1` --- src/framework/MOM_error_handler.F90 | 80 ++++++- src/framework/posix.F90 | 347 ++++++++++++++++++++++++++++ src/framework/posix.h | 28 +++ 3 files changed, 454 insertions(+), 1 deletion(-) create mode 100644 src/framework/posix.F90 create mode 100644 src/framework/posix.h diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 6051fed08b..223423c7fc 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -3,7 +3,12 @@ module MOM_error_handler ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms_infra, only : num_PEs use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL +use posix, only : getpid, getppid, handler_interface +use posix, only : signal, kill, SIGUSR1 +use posix, only : sigjmp_buf, siglongjmp +use posix, only : sleep implicit none ; private @@ -15,6 +20,7 @@ module MOM_error_handler public :: is_root_pe, stdlog, stdout !> Integer parameters encoding the severity of an error message public :: NOTE, WARNING, FATAL +public :: disable_fatal_errors, enable_fatal_errors integer :: verbosity = 6 !< Verbosity level: @@ -40,6 +46,19 @@ module MOM_error_handler integer :: callTreeIndentLevel = 0 !< The level of calling within the call tree +! Error handling + +logical :: ignore_fatal = .false. + !< If true, ignore FATAL errors and jump to a prior state. +integer, parameter :: err_signal = SIGUSR1 + !< Signal used to trigger the error handler +integer :: err_pid + !< Process ID for the error handler (either self or MPI launcher) +procedure(handler_interface), pointer :: prior_handler + !< The default signal handler used before signal() setup (usually SIG_DFT) +type(sigjmp_buf) :: prior_env + !< Buffer containing the program state to be recovered by longjmp + contains !> This provides a convenient interface for writing an informative comment, depending @@ -61,6 +80,49 @@ subroutine MOM_mesg(message, verb, all_print) end subroutine MOM_mesg +!> Enable error handling, replacing FATALs in MOM_error with err_handler. +subroutine disable_fatal_errors(env) + type(sigjmp_buf), intent(in) :: env + !> Process recovery state after FATAL errors + + integer :: rc + integer :: sig + + ignore_fatal = .true. + + ! TODO: Only need to call this once; move to an init() function? + if (num_PEs() > 1) then + err_pid = getppid() + else + err_pid = getpid() + endif + + ! Store the program state + prior_env = env + + ! Setup the signal handler + ! NOTE: Passing parameters to signal() in GFortran causes a compiler error. + ! We avert this by copying err_signal to a variable. + sig = err_signal + ! TODO: Use sigaction() in place of signal() + prior_handler => signal(sig, err_handler) +end subroutine disable_fatal_errors + +!> Disable the error handler and abort on FATAL +subroutine enable_fatal_errors() + integer :: rc + integer :: sig + procedure(handler_interface), pointer :: dummy + + ignore_fatal = .false. + err_pid = -1 ! NOTE: 0 might be safer, since it's unusable. + + ! Restore the original signal handler (usually SIG_DFT). + sig = err_signal + ! NOTE: As above, we copy the err_signal to accommodate GFortran. + dummy => signal(sig, prior_handler) +end subroutine enable_fatal_errors + !> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) @@ -71,6 +133,7 @@ subroutine MOM_error(level, message, all_print) ! This provides a convenient interface for writing an error message ! with run-time filter based on a verbosity. logical :: write_msg + integer :: rc write_msg = is_root_pe() if (present(all_print)) write_msg = write_msg .or. all_print @@ -81,6 +144,15 @@ subroutine MOM_error(level, message, all_print) case (WARNING) if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) case (FATAL) + if (ignore_fatal) then + print *, "(FATAL): " // message + rc = kill(err_pid, err_signal) + ! NOTE: MPI launchers require, in their words, "a few seconds" to + ! propagate the signal to the nodes, so we wait here to avoid + ! anomalous FATAL calls. + ! In practice, the signal will take control before sleep() completes. + rc = sleep(3) + endif if (verbosity>=0) call MOM_err(FATAL, message) case default call MOM_err(level, message) @@ -180,7 +252,13 @@ subroutine assert(logical_arg, msg) if (.not. logical_arg) then call MOM_error(FATAL, msg) endif - end subroutine assert +!> Restore the process state via longjmp after receiving a signal. +subroutine err_handler(sig) + integer, intent(in) :: sig + !< Signal passed to the handler (unused) + call siglongjmp(prior_env, 1) +end subroutine + end module MOM_error_handler diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 new file mode 100644 index 0000000000..0a534db6c0 --- /dev/null +++ b/src/framework/posix.F90 @@ -0,0 +1,347 @@ +!> Interface to the libc POSIX API +#include "posix.h" + +module posix + +use, intrinsic :: iso_c_binding, only : c_char +use, intrinsic :: iso_c_binding, only : c_int +use, intrinsic :: iso_c_binding, only : c_long +use, intrinsic :: iso_c_binding, only : c_null_char +use, intrinsic :: iso_c_binding, only : c_funptr +use, intrinsic :: iso_c_binding, only : c_funloc +use, intrinsic :: iso_c_binding, only : c_f_procpointer + +implicit none + +!> Container for the jump point buffer created by setjmp(). +!! +!! The buffer typically contains the current register values, stack pointers, +!! and any information required to restore the process state. +type, bind(c) :: jmp_buf + private + character(kind=c_char) :: state(JMP_BUF_SIZE) + !< Unstructured array of bytes used to store the process state +end type jmp_buf + +!> Container for the jump point buffer (with signals) created by sigsetjmp() +!! +!! In addition to the content stored by `jmp_buf`, it also stores signal state. +type, bind(c) :: sigjmp_buf + private + character(kind=c_char) :: state(SIGJMP_BUF_SIZE) + !< Unstructured array of bytes used to store the process state +end type sigjmp_buf + +! POSIX signals +integer, parameter :: SIGUSR1 = POSIX_SIGUSR1 + !< Signal number for SIGUSR1 (user-defined signal 1) + +interface + !> C interface to POSIX chmod() + !! Users should use the Fortran-defined chmod() function. + function chmod_posix(path, mode) result(rc) bind(c, name="chmod") + ! #include + ! int chmod(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function chmod_posix + + !> C interface to POSIX signal() + !! Users should use the Fortran-defined signal() function. + function signal_posix(sig, func) result(handle) bind(c, name="signal") + ! #include + ! void (*signal(int sig, void (*func)(int)))(int); + import :: c_int, c_funptr + + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be configured + type(c_funptr), value, intent(in) :: func + !< Function handle to be called when `sig` is raised + type(c_funptr) :: handle + !< Prior handle for sig to be replaced by `func` + end function signal_posix + + !> C interface to POSIX kill() + !! Users should use the Fortran-defined kill() function. + function kill_posix(pid, sig) result(rc) bind(c, name="kill") + ! #include + ! int kill(pid_t pid, int sig); + import :: c_int + + integer(kind=c_int), value, intent(in) :: pid + !< Process ID which is to receive the signal + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be sent to the process + integer(kind=c_int) :: rc + !< Function return code + end function kill_posix + + !> C interface to POSIX getpid() + !! Users should use the Fortran-defined getpid() function. + function getpid_posix() result(pid) bind(c, name="getpid") + ! #include + ! pid_t getpid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the current process. + end function getpid_posix + + !> C interface to POSIX getppid() + !! Users should use the Fortran-defined getppid() function. + function getppid_posix() result(pid) bind(c, name="getppid") + ! #include + ! pid_t getppid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the parent process to the current process. + end function getppid_posix + + !> C interface to POSIX sleep() + !! Users should use the Fortran-defined sleep() function. + function sleep_posix(seconds) result(rc) bind(c, name="sleep") + ! #include + ! unsigned int sleep(unsigned int seconds); + import :: c_int + + integer(kind=c_int), value, intent(in) :: seconds + !< Number of real-time seconds which the thread should sleep + integer(kind=c_int) :: rc + !< Function return code + end function + + ! NOTE: The C setjmp and sigsetjmp functions *must* be called explicitly by + ! the Fortran code, rather than through a wrapper Fortran function. + ! + ! Otherwise, setjmp() will capture the stack inside the wrapper, rather than + ! the point where setjmp() is called. + ! + ! Hence, we remove the `_posix` suffix and call these explicitly. + ! (The integer kind <-> c_int conversion will need to be addressed.) + + ! NOTE: POSIX explicitly says setjmp/sigsetjmp may be either a function or a + ! macro, and thus bind() may point to a nonexistent function. + ! e.g. sigsetjmp is a macro to __sigsetjmp in glibc, so we use a macro. + + !> Save the current program execution state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + function setjmp(env) result(rc) bind(c, name="setjmp") + ! #include + ! int setjmp(jmp_buf env); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int) :: rc + !< Function return code; set to 0 if setjmp() was called, otherwise + !! specified by the corresponding longjmp() call. + end function setjmp + + !> Save the current execution and ,optionally, the signal state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + !! + !! If `savesigs` is set to a nonzero value, then the signal state is included + !! in the program state. + function sigsetjmp(env, savesigs) result(rc) bind(c, name=SIGSETJMP_NAME) + ! #include + ! int sigsetjmp(jmp_buf env, int savesigs); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int), value, intent(in) :: savesigs + !< Flag to enable signal state when set to a nonzero value + integer(kind=c_int) :: rc + !< Function return code; set to 0 if sigsetjmp() was called, otherwise + !! specified by the corresponding siglongjmp() call. + end function sigsetjmp + + !> C interface to POSIX longjmp() + !! Users should use the Fortran-defined longjmp() function. + subroutine longjmp_posix(env, val) bind(c, name="longjmp") + ! #include + ! int longjmp(jmp_buf env, int val); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to setjmp() + end subroutine longjmp_posix + + !> C interface to POSIX siglongjmp() + !! Users should use the Fortran-defined siglongjmp() function. + subroutine siglongjmp_posix(env, val) bind(c, name="longjmp") + ! #include + ! int siglongjmp(jmp_buf env, int val); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to sigsetjmp() + end subroutine siglongjmp_posix + + ! Note on types: + ! mode_t: + ! "According to POSIX, it shall be an integer type." + ! pid_t: + ! "According to POSIX, it shall be a signed integer type, and the + ! implementation shall support one or more programming environments where + ! the width of pid_t is no greater than the width of the type long. + ! jmp_buf: + ! This is a strongly platform-dependent variable, large enough to contain + ! a complete copy of the process execution state (registers, stack, etc). + ! sigjmp_buf: + ! A more comprehensive version of jmp_buf which contains signal state. +end interface + +abstract interface + !> Function interface for signal handlers + subroutine handler_interface(sig) + integer, intent(in) :: sig + !> Input signal to handler + end subroutine +end interface + +contains + +!> Change mode of a file +!! +!! This changes the file permission of file `path` to `mode` following POSIX +!! conventions. If successful, it returns zero. Otherwise, it returns -1. +function chmod(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = chmod_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function chmod + +!> Create a signal handler `handle` to be called when `sig` is detected. +!! +!! If successful, the previous handler for `sig` is returned. Otherwise, +!! SIG_ERR is returned. +function signal(sig, func) result(handle) + integer, intent(in) :: sig + procedure(handler_interface) :: func + procedure(handler_interface), pointer :: handle + + integer(kind=c_int) :: sig_c + type(c_funptr) :: handle_c + + sig_c = int(sig, kind=c_int) + handle_c = signal_posix(sig_c, c_funloc(func)) + call c_f_procpointer(handle_c, handle) +end function signal + +!> Send signal `sig` to process `pid`. +!! +!! If successful, this function returns 0. Otherwise, it returns -1. +function kill(pid, sig) result(rc) + integer, intent(in) :: pid + integer, intent(in) :: sig + integer :: rc + + integer(kind=c_int) :: pid_c, sig_c, rc_c + + pid_c = int(pid, kind=c_int) + sig_c = int(sig, kind=c_int) + rc_c = kill_posix(pid_c, sig_c) + rc = int(rc_c) +end function kill + +!> Get the ID of the current process. +function getpid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getpid_posix() + pid = int(pid_c) +end function getpid + +!> Get the ID of the parent process of the current process. +function getppid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getppid_posix() + pid = int(pid_c) +end function getppid + +!> Force the process to a sleep state for `seconds` seconds. +!! +!! The sleep state may be interrupted by a signal. If it sleeps for the entire +!! duration, then it returns 0. Otherwise, it returns the number of seconds +!! remaining at the point of interruption. +function sleep(seconds) result(rc) + ! NOTE: This function may replace an existing compiler `sleep()` extension. + integer, intent(in) :: seconds + integer :: rc + + integer(kind=c_int) :: seconds_c + integer(kind=c_int) :: rc_c + + seconds_c = int(seconds, kind=c_int) + rc_c = sleep_posix(seconds_c) + rc = int(rc_c) +end function sleep + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved +!! back to this `setjmp`, except the function will now return `val`. +subroutine longjmp(env, val) + type(jmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call longjmp_posix(env, val_c) +end subroutine longjmp + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved back +!! to this `setjmp`, except the function will now return `val`. +!! +!! `siglongjmp` behaves in the same manner as `longjmp`, but also provides +!! predictable handling of the signal state. +subroutine siglongjmp(env, val) + type(sigjmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call siglongjmp_posix(env, val_c) +end subroutine siglongjmp + +end module posix diff --git a/src/framework/posix.h b/src/framework/posix.h new file mode 100644 index 0000000000..6d6012c5e7 --- /dev/null +++ b/src/framework/posix.h @@ -0,0 +1,28 @@ +#ifndef MOM6_POSIX_H_ +#define MOM6_POSIX_H_ + +! JMP_BUF_SIZE should be set to sizeof(jmp_buf). +! If unset, then use a typical glibc value (25 long ints) +#ifndef JMP_BUF_SIZE +#define JMP_BUF_SIZE 200 +#endif + +! If unset, assume jmp_buf and sigjmp_buf are equivalent (as in glibc). +#ifndef SIGJMP_BUF_SIZE +#define SIGJMP_BUF_SIZE JMP_BUF_SIZE +#endif + +! glibc defines sigsetjmp as __sigsetjmp via macro readable from . +! Perhaps autoconf can configure this one... +! TODO: Need a solution here! +#ifndef SIGSETJMP_NAME +#define SIGSETJMP_NAME "__sigsetjmp" +#endif + +! This should be defined by /usr/include/signal.h +! If unset, we use the most common (x86) value +#ifndef POSIX_SIGUSR1 +#define POSIX_SIGUSR1 10 +#endif + +#endif From 08582eead205e65680f5f60247ffa1713cdc6496 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Thu, 31 Mar 2022 14:34:51 -0400 Subject: [PATCH 075/155] add residual loss term for internal tides (#95) Co-authored-by: Raphael Dussin Co-authored-by: Marshall Ward --- .../lateral/MOM_internal_tides.F90 | 129 ++++++++++++++++-- 1 file changed, 114 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index f6d8d05dcf..9efb455854 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -65,6 +65,10 @@ module MOM_internal_tides !< identifies reflection cells where double reflection !! is possible (i.e. ridge cells) ! (could be in G control structure) + real, allocatable, dimension(:,:) :: trans + !< partial transmission coeff for each "coast cell" + real, allocatable, dimension(:,:) :: residual + !< residual of reflection and transmission coeff for each "coast cell" real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss @@ -79,6 +83,8 @@ module MOM_internal_tides !! the energy losses in [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss + !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, @@ -87,6 +93,8 @@ module MOM_internal_tides !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real :: q_itides !< fraction of local dissipation [nondim] @@ -107,6 +115,8 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. + logical :: apply_residual_drag + !< If true, apply sink from residual term of reflection/transmission. real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] @@ -122,10 +132,11 @@ module MOM_internal_tides ! Diag handles relevant to all modes, frequencies, and angles integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 + integer :: id_trans = -1, id_residual = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 ! Diag handles considering: sums over all modes, frequencies, and angles integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 - integer :: id_tot_Froude_loss = -1, id_tot_allprocesses_loss = -1 + integer :: id_tot_Froude_loss = -1, id_tot_residual_loss = -1, id_tot_allprocesses_loss = -1 ! Diag handles considering: all modes & freqs; summed over angles integer, allocatable, dimension(:,:) :: & id_En_mode, & @@ -184,7 +195,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & flux_prec_y real, dimension(SZI_(G),SZJ_(G)) :: & tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] - tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_allprocesses_loss, & + tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] drag_scale, & ! bottom drag scale [T-1 ~> s-1] @@ -198,6 +209,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] + real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] @@ -211,7 +223,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle I_rho0 = 1.0 / GV%Rho0 - cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. + cn_subRO = 1e-30*US%m_s_to_L_T + en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T ! init local arrays drag_scale(:,:) = 0. @@ -286,8 +299,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Propagate the waves. do m=1,CS%NMode ; do fr=1,CS%Nfreq + + CS%TKE_residual_loss(:,:,:,fr,m) = 0. + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle) + G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) enddo ; enddo ! Check for En<0 - for debugging, delete later @@ -502,6 +518,23 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & enddo ; enddo enddo ; enddo ; enddo + ! loss from residual of reflection/transmission coefficients + if (CS%apply_residual_drag) then + + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + ! implicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & + ! (CS%En(i,j,a,fr,m) + en_subRO)) + ! rewritten to minimize number of divisions: + CS%En(i,j,a,fr,m) = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + dt * CS%TKE_residual_loss(i,j,a,fr,m)) + + ! explicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) - dt * CS%TKE_residual_loss(i,j,a,fr,m) + enddo ; enddo ; enddo ; enddo ; enddo + endif + + ! Check for energy conservation on computational domain.************************* do m=1,CS%NMode ; do fr=1,CS%Nfreq call sum_En(G,CS,CS%En(:,:,:,fr,m),'prop_int_tide') @@ -537,21 +570,25 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & tot_quad_loss(:,:) = 0.0 tot_itidal_loss(:,:) = 0.0 tot_Froude_loss(:,:) = 0.0 + tot_residual_loss(:,:) = 0.0 tot_allprocesses_loss(:,:) = 0.0 do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) tot_Froude_loss(i,j) = tot_Froude_loss(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + tot_residual_loss(i,j) = tot_residual_loss(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) enddo ; enddo ; enddo ; enddo ; enddo do j=js,je ; do i=is,ie - tot_allprocesses_loss(i,j) = ((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & - (tot_itidal_loss(i,j) + tot_Froude_loss(i,j))) + tot_allprocesses_loss(i,j) = ((((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & + tot_itidal_loss(i,j)) + tot_Froude_loss(i,j)) + & + tot_residual_loss(i,j)) enddo ; enddo CS%tot_leak_loss = tot_leak_loss CS%tot_quad_loss = tot_quad_loss CS%tot_itidal_loss = tot_itidal_loss CS%tot_Froude_loss = tot_Froude_loss + CS%tot_residual_loss = tot_residual_loss CS%tot_allprocesses_loss = tot_allprocesses_loss if (CS%id_tot_leak_loss > 0) then call post_data(CS%id_tot_leak_loss, tot_leak_loss, CS%diag) @@ -565,6 +602,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%id_tot_Froude_loss > 0) then call post_data(CS%id_tot_Froude_loss, tot_Froude_loss, CS%diag) endif + if (CS%id_tot_residual_loss > 0) then + call post_data(CS%id_tot_residual_loss, tot_residual_loss, CS%diag) + endif if (CS%id_tot_allprocesses_loss > 0) then call post_data(CS%id_tot_allprocesses_loss, tot_allprocesses_loss, CS%diag) endif @@ -577,8 +617,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & - ((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & - (CS%TKE_itidal_loss(i,j,a,fr,m) + CS%TKE_Froude_loss(i,j,a,fr,m))) + ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & + CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & + CS%TKE_residual_loss(i,j,a,fr,m)) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) @@ -992,7 +1033,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) +subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1006,7 +1047,9 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct - + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. @@ -1097,18 +1140,19 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) !call sum_En(G, CS, En, 'post-propagate_x') ! Update halos call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) !call sum_En(G, CS, En, 'post-propagate_y') @@ -1402,7 +1446,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS end subroutine propagate_corner_spread !> Propagates the internal wave energy in the logical x-direction. -subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1419,6 +1463,9 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. @@ -1455,6 +1502,10 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j)) enddo ; enddo enddo ! a-loop @@ -1476,7 +1527,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) end subroutine propagate_x !> Propagates the internal wave energy in the logical y-direction. -subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1493,6 +1544,9 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. @@ -1530,6 +1584,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j)) + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & @@ -2167,7 +2226,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=160) :: var_descript character(len=200) :: filename character(len=200) :: refl_angle_file, land_mask_file - character(len=200) :: refl_pref_file, refl_dbl_file + character(len=200) :: refl_pref_file, refl_dbl_file, trans_file character(len=200) :: dy_Cu_file, dx_Cv_file character(len=200) :: h2_file @@ -2286,6 +2345,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & "If true, apply scattering due to small-scale roughness as a sink.", & default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & + "If true, TBD", & + default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& "of the quadratic drag terms for internal tides.", & @@ -2324,10 +2386,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%TKE_quad_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_Froude_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_residual_loss(isd:ied,jsd:jed), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2423,6 +2487,32 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) else ; CS%refl_dbl(i,j) = .false. ; endif enddo ; enddo + ! Read in the transmission coefficient and infer the residual + call get_param(param_file, mdl, "TRANS_FILE", trans_file, & + "The path to the file containing the transmission coefficent for internal tides.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(trans_file) + allocate(CS%trans(isd:ied,jsd:jed), source=0.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/TRANS_FILE", filename) + call MOM_read_data(filename, 'trans', CS%trans, G%domain) + else + if (trim(trans_file) /= '' ) call MOM_error(FATAL, & + "TRANS_FILE: "//trim(filename)//" not found") + endif + + call pass_var(CS%trans,G%domain) + ! residual + allocate(CS%residual(isd:ied,jsd:jed), source=0.0) + do j=jsd,jed + do i=isd,ied + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) + endif + enddo + enddo + call pass_var(CS%residual,G%domain) + ! Read in prescribed land mask from file (if overwriting -BDM). ! This should be done in MOM_initialize_topography subroutine ! defined in MOM_fixed_initialization.F90 (BDM) @@ -2462,6 +2552,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') CS%id_refl_pref = register_diag_field('ocean_model', 'refl_pref', diag%axesT1, & Time, 'Partial reflection coefficients', '') + CS%id_trans = register_diag_field('ocean_model', 'trans', diag%axesT1, & + Time, 'Partial transmission coefficients', '') + CS%id_residual = register_diag_field('ocean_model', 'residual', diag%axesT1, & + Time, 'Residual of reflection and transmission coefficients', '') CS%id_dx_Cv = register_diag_field('ocean_model', 'dx_Cv', diag%axesT1, & Time, 'North face unblocked width', 'm', conversion=US%L_to_m) CS%id_dy_Cu = register_diag_field('ocean_model', 'dy_Cu', diag%axesT1, & @@ -2471,6 +2565,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Output reflection parameters as diags here (not needed every timestep) if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) + if (CS%id_trans > 0) call post_data(CS%id_trans, CS%trans, CS%diag) + if (CS%id_residual > 0) call post_data(CS%id_residual, CS%residual, CS%diag) if (CS%id_dx_Cv > 0) call post_data(CS%id_dx_Cv, G%dx_Cv, CS%diag) if (CS%id_dy_Cu > 0) call post_data(CS%id_dy_Cu, G%dy_Cu, CS%diag) if (CS%id_land_mask > 0) call post_data(CS%id_land_mask, G%mask2dT, CS%diag) @@ -2500,6 +2596,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & + Time, 'Internal tide energy loss to residual on slopes', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) From 356671c202419346414f9c28661b3dab8017ccdc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 23 Mar 2022 15:52:49 -0400 Subject: [PATCH 076/155] +Refactor writing the vertical_coordinate file Rearrange how the vertical_coordinate file is written, to avoid an unnecessary repetition of the writing of this file, and to prepare for the Hybgen grid generator code to write its own version of this file. The specific changes include: - Added the new subroutine write_regrid_file() to write the vertical_coordinate file when in ALE mode. - Relocated the code to write the vertical_coordinate file in ALE mode from ALE_writeCoordinateFile to write_regrid_file() - Moved the call to write_vertgrid_file() into initialize_MOM(), and do not call it when USE_REGRIDDING=True, since in this case this file will be rewritten again when write_regrid_file() is called. - Eliminated the write_geom and output_dir arguments to MOM_initialize_coord() All answers and output are bitwise identical. --- src/ALE/MOM_ALE.F90 | 32 ++++------------- src/ALE/MOM_regridding.F90 | 36 +++++++++++++++++-- src/core/MOM.F90 | 20 +++++------ .../MOM_coord_initialization.F90 | 14 +++----- src/ocean_data_assim/MOM_oda_driver.F90 | 3 +- 5 files changed, 56 insertions(+), 49 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index d8eee55c14..fa195d57eb 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -21,8 +21,6 @@ module MOM_ALE use MOM_error_handler, only : callTree_showQuery 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, 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 @@ -34,8 +32,8 @@ module MOM_ALE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme use MOM_regridding, only : regriddingDefaultBoundaryExtrapolation use MOM_regridding, only : regriddingDefaultMinThickness -use MOM_regridding, only : regridding_CS, set_regrid_params -use MOM_regridding, only : getCoordinateInterfaces, getCoordinateResolution +use MOM_regridding, only : regridding_CS, set_regrid_params, write_regrid_file +use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : getCoordinateUnits, getCoordinateShortName use MOM_regridding, only : getStaticThickness use MOM_remapping, only : initialize_remapping, end_remapping @@ -333,7 +331,7 @@ end subroutine ALE_register_diags !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. subroutine adjustGridForIntegrity( CS, G, GV, h ) - type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ALE_CS), intent(in) :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid thickness that @@ -1413,26 +1411,10 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=*), intent(in) :: directory !< directory for writing grid info character(len=240) :: filepath - type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - 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") - ds(:) = getCoordinateResolution( CS%regridCS, undo_scaling=.true. ) - dsi(1) = 0.5*ds(1) - dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) - dsi(GV%ke+1) = 0.5*ds(GV%ke) - - vars(1) = var_desc('ds', getCoordinateUnits( CS%regridCS ), & - 'Layer Coordinate Thickness','1','L','1') - vars(2) = var_desc('ds_interface', getCoordinateUnits( CS%regridCS ), & - 'Layer Center Coordinate Separation','1','i','1') - - 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) + + filepath = trim(directory) // trim("Vertical_coordinate") + + call write_regrid_file(CS%regridCS, GV, filepath) end subroutine ALE_writeCoordinateFile diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 008475b16d..4c99ce457d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -6,6 +6,8 @@ module MOM_regridding use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data +use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE +use MOM_io, only : create_file, MOM_write_field, close_file, file_type use MOM_io, only : verify_variable_units, slasher use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs @@ -129,9 +131,8 @@ module MOM_regridding ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main public inflate_vanished_layers_old, check_remapping_grid, check_grid_column -public set_regrid_params, get_regrid_size +public set_regrid_params, get_regrid_size, write_regrid_file public uniformResolution, setCoordinateResolution -public build_rho_column public set_target_densities_from_GV, set_target_densities public set_regrid_max_depths, set_regrid_max_thickness public getCoordinateResolution, getCoordinateInterfaces @@ -2107,6 +2108,37 @@ subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) end subroutine set_regrid_max_thickness +!> Write the vertical coordinate information into a file. +!! This subroutine writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model when in ALE mode. +subroutine write_regrid_file( CS, GV, filepath ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + character(len=*), intent(in) :: filepath !< The full path to the file to write + + type(vardesc) :: vars(2) + type(fieldtype) :: fields(2) + type(file_type) :: IO_handle ! The I/O handle of the fileset + real :: ds(GV%ke), dsi(GV%ke+1) + + ds(:) = CS%coord_scale * CS%coordinateResolution(:) + dsi(1) = 0.5*ds(1) + dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) + dsi(GV%ke+1) = 0.5*ds(GV%ke) + + vars(1) = var_desc('ds', getCoordinateUnits( CS ), & + 'Layer Coordinate Thickness', '1', 'L', '1') + vars(2) = var_desc('ds_interface', getCoordinateUnits( CS ), & + 'Layer Center Coordinate Separation', '1', 'i', '1') + + call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call MOM_write_field(IO_handle, fields(1), ds) + call MOM_write_field(IO_handle, fields(2), dsi) + call close_file(IO_handle) + +end subroutine write_regrid_file + + !------------------------------------------------------------------------------ !> Query the fixed resolution data function getCoordinateResolution( CS, undo_scaling ) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5b35c01a42..f3d8869320 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -57,7 +57,7 @@ module MOM use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS use MOM_check_scaling, only : check_MOM6_scaling_factors -use MOM_coord_initialization, only : MOM_initialize_coord +use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS @@ -2484,8 +2484,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Initialize dynamically evolving fields, perhaps from restart files. call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, US, param_file, write_geom_files, & - dirs%output_directory, CS%tv, G%max_depth) + call MOM_initialize_coord(GV, US, param_file, CS%tv, G%max_depth) call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then @@ -2648,8 +2647,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! \todo This block exists for legacy reasons and we should phase it out of ! all examples. !### if (CS%debug) then - call uvchksum("Pre ALE adjust init cond [uv]", & - CS%u, CS%v, G%HI, haloshift=1) + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") @@ -2712,19 +2710,21 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! must be defined. call set_masks_for_axes(G, diag) - ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, GV, US, CS%tv, CS%diag) - call callTree_waypoint("static fields written (initialize_MOM)") - ! Register the volume cell measure (must be one of first diagnostics) call register_cell_measure(G, CS%diag, Time) call cpu_clock_begin(id_clock_MOM_init) + ! Diagnose static fields AND associate areas/volumes with axes + call write_static_fields(G, GV, US, CS%tv, CS%diag) + call callTree_waypoint("static fields written (initialize_MOM)") + if (CS%use_ALE_algorithm) then call ALE_writeCoordinateFile( CS%ALE_CSp, GV, dirs%output_directory ) + call callTree_waypoint("ALE initialized (initialize_MOM)") + elseif (write_geom_files) then + call write_vertgrid_file(GV, US, param_file, dirs%output_directory) endif call cpu_clock_end(id_clock_MOM_init) - call callTree_waypoint("ALE initialized (initialize_MOM)") CS%useMEKE = MEKE_init(Time, G, US, param_file, diag, CS%MEKE_CSp, CS%MEKE, restart_CSp) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 286dfa7d95..311145bce1 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -9,8 +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 : 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_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -20,7 +19,7 @@ module MOM_coord_initialization implicit none ; private -public MOM_initialize_coord +public MOM_initialize_coord, write_vertgrid_file ! 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 @@ -33,13 +32,11 @@ module MOM_coord_initialization !> MOM_initialize_coord sets up time-invariant quantities related to MOM6's !! vertical coordinate. -subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_depth) +subroutine MOM_initialize_coord(GV, US, PF, tv, max_depth) type(verticalGrid_type), intent(inout) :: GV !< Ocean 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, intent(in) :: write_geom !< If true, write grid geometry files. - character(len=*), intent(in) :: output_dir !< The directory into which to write files. type(thermo_var_ptrs), intent(inout) :: tv !< The thermodynamic variable structure. real, intent(in) :: max_depth !< The ocean's maximum depth [Z ~> m]. ! Local @@ -107,12 +104,9 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) -! Copy the maximum depth across from the input argument + ! Copy the maximum depth across from the input argument GV%max_depth = max_depth -! Write out all of the grid data used by this run. - if (write_geom) call write_vertgrid_file(GV, US, PF, output_dir) - call callTree_leave('MOM_initialize_coord()') end subroutine MOM_initialize_coord diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index f183231c88..fc76c23480 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -280,8 +280,7 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) call set_grid_metrics(dG, PF, CS%US) call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US) - call MOM_initialize_coord(CS%GV, CS%US, PF, .false., & - dirs%output_directory, tv_dummy, dG%max_depth) + call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth) call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) call MOM_grid_init(CS%Grid, PF, global_indexing=.false.) call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV) From 9c4363ed2a2b152b72a5ba860c8d686625cd302b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:51:40 -0400 Subject: [PATCH 077/155] +Add optional conversion argument to register_diag_scalar Add the optional conversion argument to register_diag_scalar, which works analogously to the argument that is already available in register_diag_field. All answers are bitwise identical, but there is a new optional argument in a public type. --- src/framework/MOM_diag_mediator.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index eb24c994f8..92d53330a7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2775,7 +2775,7 @@ 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) + cmor_long_name, cmor_units, cmor_standard_name, conversion) 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" @@ -2796,6 +2796,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file ! Local variables real :: MOM_missing_value @@ -2826,6 +2827,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call assert(associated(diag), 'register_scalar_field: diag allocation failed') diag%fms_diag_id = fms_id diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion endif if (present(cmor_field_name)) then @@ -2856,6 +2858,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) cmor_diag%fms_diag_id = fms_id cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion endif endif From a6992a9d6733747035732b3538ca5483c058bd50 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:52:10 -0400 Subject: [PATCH 078/155] Convert global_area_mean diagnostics when writing Use conversion argument during registration and tmp_scale argument in the calls to global_area_mean for averaged fields in the MOM_forcing_type and MOM_diagnostics modules. Also added or corrected some descriptive comments and fixed an extra unit conversion factor in one recently added calculation of ustar that was likely not used. All answers are bitwise identical. --- src/core/MOM_forcing_type.F90 | 102 ++++++++++++++-------------- src/diagnostics/MOM_diagnostics.F90 | 25 +++---- 2 files changed, 62 insertions(+), 65 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 23b8b9da7c..bdf4823f81 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1489,39 +1489,41 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, !========================================================================= ! area averaged surface mass transport - handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & - long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)',& - units='kg m-2 s-1', standard_name='water_flux_into_sea_water_area_averaged', & - cmor_field_name='ave_wfo', & - cmor_standard_name='rainfall_flux_area_averaged', & + handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & + long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_area_averaged', & + cmor_field_name='ave_wfo', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Water Transport Into Sea Water Area Averaged') - handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag,& - long_name='Area averaged evap/condense at ocean surface', & - units='kg m-2 s-1', standard_name='water_evaporation_flux_area_averaged', & - cmor_field_name='ave_evs', & - cmor_standard_name='water_evaporation_flux_area_averaged', & + handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag, & + long_name='Area averaged evap/condense at ocean surface', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux_area_averaged', & + cmor_field_name='ave_evs', cmor_standard_name='water_evaporation_flux_area_averaged', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Averaged') handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& - long_name='Area integrated liquid precip into ocean', units='kg m-2 s-1', & - standard_name='rainfall_flux_area_averaged', & - cmor_field_name='ave_pr', & - cmor_standard_name='rainfall_flux_area_averaged', & + long_name='Area integrated liquid precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='rainfall_flux_area_averaged', & + cmor_field_name='ave_pr', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Averaged') - handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag,& - long_name='Area integrated frozen precip into ocean', units='kg m-2 s-1', & + handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & + long_name='Area integrated frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux_area_averaged', & - cmor_field_name='ave_prsn', & - cmor_standard_name='snowfall_flux_area_averaged', & + cmor_field_name='ave_prsn',cmor_standard_name='snowfall_flux_area_averaged', & cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Averaged') handles%id_precip_ga = register_scalar_field('ocean_model', 'precip_ga', Time, diag, & - long_name='Area averaged liquid+frozen precip into ocean', units='kg m-2 s-1') + long_name='Area averaged liquid+frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_vprec_ga = register_scalar_field('ocean_model', 'vrec_ga', Time, diag, & - long_name='Area averaged virtual liquid precip due to SSS restoring', units='kg m-2 s-1') + long_name='Area averaged virtual liquid precip due to SSS restoring', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) !=============================================================== ! surface heat flux maps @@ -1820,12 +1822,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_net_heat_coupler_ga = register_scalar_field('ocean_model', & 'net_heat_coupler_ga', Time, diag, & long_name='Area averaged surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_net_heat_surface_ga = register_scalar_field('ocean_model', & 'net_heat_surface_ga', Time, diag, long_name= & 'Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore+seaice_melt_heat or flux adjustments', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & cmor_long_name= & @@ -1834,7 +1836,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sw_ga = register_scalar_field('ocean_model', & 'sw_ga', Time, diag, & long_name='Area averaged net downward shortwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_averaged',& cmor_long_name= & @@ -1843,12 +1845,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_LwLatSens_ga = register_scalar_field('ocean_model',& 'LwLatSens_ga', Time, diag, & long_name='Area averaged longwave+latent+sensible heating',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lw_ga = register_scalar_field('ocean_model', & 'lw_ga', Time, diag, & long_name='Area averaged net downward longwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rlntds', & cmor_standard_name='surface_net_downward_longwave_flux_area_averaged',& cmor_long_name= & @@ -1857,7 +1859,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_lat_ga = register_scalar_field('ocean_model', & 'lat_ga', Time, diag, & long_name='Area averaged surface downward latent heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hflso', & cmor_standard_name='surface_downward_latent_heat_flux_area_averaged',& cmor_long_name= & @@ -1866,7 +1868,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sens_ga = register_scalar_field('ocean_model', & 'sens_ga', Time, diag, & long_name='Area averaged downward sensible heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfsso', & cmor_standard_name='surface_downward_sensible_heat_flux_area_averaged',& cmor_long_name= & @@ -2347,7 +2349,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res ! A temporary array for combinations ! of fluxes [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] real :: total_transport ! for diagnosing integrated boundary transport, in MKS units of [kg s-1] or [W] - real :: ave_flux ! for diagnosing averaged boundary flux, in MKS units of [kg m-2 s-1] or [W m-2] + real :: ave_flux ! for diagnosing averaged boundary flux in [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] real :: I_dt ! inverse time step [T-1 ~> s-1] real :: ppt2mks ! conversion between ppt and mks units [nondim] integer :: turns ! Number of index quarter turns @@ -2395,7 +2397,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif @@ -2465,7 +2467,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_evap_ga, ave_flux, diag) endif @@ -2479,7 +2481,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_precip, total_transport, diag) endif if (handles%id_precip_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_precip_ga, ave_flux, diag) endif endif @@ -2491,7 +2493,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2503,7 +2505,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2515,7 +2517,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2625,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif if (handles%id_net_heat_coupler_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif endif @@ -2669,7 +2671,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif endif @@ -2740,7 +2742,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) endif @@ -2760,7 +2762,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_sw, total_transport, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then - ave_flux = global_area_mean(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sw_ga, ave_flux, diag) endif @@ -2772,7 +2774,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lw, total_transport, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then - ave_flux = global_area_mean(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lw_ga, ave_flux, diag) endif @@ -2784,7 +2786,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lat, total_transport, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then - ave_flux = global_area_mean(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lat_ga, ave_flux, diag) endif @@ -2830,7 +2832,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_sens, total_transport, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then - ave_flux = global_area_mean(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sens_ga, ave_flux, diag) endif @@ -3228,7 +3230,7 @@ subroutine myAlloc(array, is, ie, js, je, flag) logical, optional, intent(in) :: flag !< Flag to indicate to allocate if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then - allocate(array(is:ie,js:je)) ; array(is:ie,js:je) = 0.0 + allocate(array(is:ie,js:je), source=0.0) endif ; endif ; endif end subroutine myAlloc @@ -3498,14 +3500,14 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) logical, optional, intent(in) :: UpdateUstar !< A logical to determine if Ustar should be directly averaged !! or updated from mean tau. - real :: tx_mean, ty_mean, avg - real :: iRho0 + real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg, tau2ustar integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB - iRho0 = US%L_to_Z / Rho0 + Irho0 = US%L_to_Z / Rho0 tau2ustar = .false. if (present(UpdateUstar)) tau2ustar = UpdateUstar @@ -3524,7 +3526,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) enddo ; enddo if (tau2ustar) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = US%L_to_Z*sqrt(sqrt(tx_mean**2 + ty_mean**2)*iRho0) + if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) enddo ; enddo else call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) @@ -3563,7 +3565,7 @@ subroutine homogenize_forcing(fluxes, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real :: avg + real :: avg ! Global average of a variable, in the same units as that variable logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB @@ -3681,7 +3683,7 @@ subroutine homogenize_field_t(var, G, tmp_scale) real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -3698,7 +3700,7 @@ subroutine homogenize_field_v(var, G, tmp_scale) real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, is, ie, jsB, jeB is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB @@ -3715,7 +3717,7 @@ subroutine homogenize_field_u(var, G, tmp_scale) real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, isB, ieB, js, je isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8d667503d7..ef71d9286c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1293,32 +1293,27 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array real, dimension(SZI_(G),SZJ_(G)) :: & - zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [m] + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [Z ~> m] real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. - real :: zos_area_mean ! Global area mean sea surface height [m] + real :: zos_area_mean ! Global area mean sea surface height [Z ~> m] real :: volo ! Total volume of the ocean [m3] - real :: ssh_ga ! Global ocean area weighted mean sea seaface height [m] + real :: ssh_ga ! Global ocean area weighted mean sea seaface height [Z ~> m] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ! area mean SSH if (IDs%id_ssh_ga > 0) then - ssh_ga = global_area_mean(ssh, G, scale=US%Z_to_m) + ssh_ga = global_area_mean(ssh, G, tmp_scale=US%Z_to_m) call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif ! post the dynamic sea level, zos, and zossq. - ! zos is ave_ssh with sea ice inverse barometer removed, - ! and with zero global area mean. + ! zos is ave_ssh with sea ice inverse barometer removed, and with zero global area mean. if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then - zos(:,:) = 0.0 + zos_area_mean = global_area_mean(ssh_ibc, G, tmp_scale=US%Z_to_m) do j=js,je ; do i=is,ie - zos(i,j) = US%Z_to_m*ssh_ibc(i,j) - enddo ; enddo - zos_area_mean = global_area_mean(zos, G) - do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean + zos(i,j) = ssh_ibc(i,j) - G%mask2dT(i,j)*zos_area_mean enddo ; enddo if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) if (IDs%id_zossq > 0) then @@ -1844,14 +1839,14 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) standard_name='sea_water_volume') IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& standard_name = 'sea_surface_height_above_geoid', & - long_name= 'Sea surface height above geoid', units='m') + long_name= 'Sea surface height above geoid', units='m', conversion=US%Z_to_m) IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& standard_name='square_of_sea_surface_height_above_geoid', & - long_name='Square of sea surface height above geoid', units='m2') + long_name='Square of sea surface height above geoid', units='m2', conversion=US%Z_to_m**2) IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & 'Sea Surface Height', 'm', conversion=US%Z_to_m) IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& - long_name='Area averaged sea surface height', units='m', & + long_name='Area averaged sea surface height', units='m', conversion=US%Z_to_m, & standard_name='area_averaged_sea_surface_height') IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & 'Sea Surface Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) From 39206d91b5458bca3ac058a747d2eb778ef84310 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:52:41 -0400 Subject: [PATCH 079/155] Simplify diagnostics using global_area_integral Use the tmp_scale argument in calls to global_area_integral to simplify some global integrals, and added dimensional rescaling for the time_step element of the ice_shelf control structure. Also corrected some dimensional descriptions in comments. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 41 ++++++++++++++++---------------- src/ice_shelf/MOM_marine_ice.F90 | 9 +++---- 2 files changed, 26 insertions(+), 24 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index bcb17589dc..5db9198a22 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -136,7 +136,7 @@ module MOM_ice_shelf !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - real :: time_step !< this is the shortest timestep that the ice shelf sees, and + real :: time_step !< this is the shortest timestep that the ice shelf sees [T ~> s], and !! is equal to the forcing timestep (it is passed in when the shelf !! is initialized - so need to reorganize MOM driver. !! it will be the prognistic timestep ... maybe. @@ -153,8 +153,9 @@ module MOM_ice_shelf real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [degC] real :: S0 !< Salinity at ocean surface in the restoring region [ppt]. - real :: input_flux !< Ice volume flux at an upstream open boundary [m3 s-1]. - real :: input_thickness !< Ice thickness at an upstream open boundary [m]. + real :: input_flux !< The vertically integrated inward ice thickness flux per + !! unit face length at an upstream boundary [Z L T-1 ~> m2 s-1] + real :: input_thickness !< Ice thickness at an upstream open boundary [Z ~> m]. type(time_type) :: Time !< The component's time. type(EOS_type) :: eqn_of_state !< Type that indicates the @@ -368,7 +369,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) CS%Time = Time if (CS%override_shelf_movement) then - CS%time_step = time_step + CS%time_step = US%s_to_T*time_step ! update shelf mass if (CS%mass_from_file) call update_shelf_mass(G, US, CS, ISS, Time) endif @@ -1109,7 +1110,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then - dTime = real_to_time(CS%time_step) + dTime = real_to_time(US%T_to_s*CS%time_step) ! Compute changes in mass after at least one full time step if (CS%Time > dTime) then @@ -1144,8 +1145,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) delta_float_mass(i,j) = 0.0 endif enddo ; enddo - delta_mass_shelf = US%kg_m2s_to_RZ_T*(global_area_integral(delta_float_mass, G, scale=US%RZ_to_kg_m2, & - area=ISS%area_shelf_h) / CS%time_step) + delta_mass_shelf = global_area_integral(delta_float_mass, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step else! first time step delta_mass_shelf = 0.0 endif @@ -1166,8 +1167,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) balancing_area = global_area_integral(bal_frac, G) if (balancing_area > 0.0) then - balancing_flux = ( US%kg_m2s_to_RZ_T*global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & - area=ISS%area_shelf_h) + & + balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & delta_mass_shelf ) / balancing_area else balancing_flux = 0.0 @@ -1184,7 +1185,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) enddo ; enddo if (CS%debug) then - write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, CS%time_step + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, US%T_to_s*CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1487,15 +1488,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & - "Non-dimensional factor applied to shelf thermodynamic "//& - "fluxes.", units="none", default=1.0) + "Non-dimensional factor applied to shelf thermodynamic fluxes.", & + units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & "The viscosity of the ice.", & units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the "//& - "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) + "The molecular kinimatic viscosity of sea water at the freezing temperature.", & + units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & default=0.0) @@ -1511,7 +1512,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=0.0) + "The default value is given by DT.", units="s", default=0.0, scale=US%s_to_T) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & "The minimum ocean column thickness where melting is allowed.", & @@ -1571,9 +1572,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & - "volume flux at upstream boundary", units="m2 s-1", default=0.) + "volume flux at upstream boundary", units="m2 s-1", default=0., scale=US%m_to_Z*US%m_s_to_L_T) call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & - "flux thickness at upstream boundary", units="m", default=1000.) + "flux thickness at upstream boundary", units="m", default=1000., scale=US%m_to_Z) else ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & @@ -2005,7 +2006,7 @@ end subroutine initialize_shelf_mass !> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf. !>>acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate !>>positive for accumulation negative for ablation -subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes,time_step, Time) +subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe @@ -2113,8 +2114,8 @@ end subroutine update_shelf_mass subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. - real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nodim]. - real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nondim]. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using !! the data_override capability (only for MOSAIC grids) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 64d4dbfdab..f24f9b1881 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -176,8 +176,9 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Runtime parameter handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice -! 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_marine_ice" ! This module's name. if (associated(CS)) then @@ -197,8 +198,8 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & "Fraction of grid cell which iceberg must occupy, so that fluxes "//& - "below berg are set to zero. Not applied for negative "//& - "values.", units="non-dim", default=-1.0) + "below berg are set to zero. Not applied for negative values.", & + units="nondim", default=-1.0) end subroutine marine_ice_init From 305f744731c380525d67134f9e57f3c8e855a9e8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:53:07 -0400 Subject: [PATCH 080/155] Rescale new_depth in apply_topography_edits_from_file Rescaled the new_depth variable in apply_topography_edits_from_file, and used source arguments to initialize 6 allocated variables. All answers are bitwise identical. --- .../MOM_shared_initialization.F90 | 30 +++++++++---------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index fc5ceaf3e4..87de12a9fa 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -184,7 +184,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(:), allocatable :: new_depth ! The new values of the depths [m] + real, dimension(:), allocatable :: new_depth ! The new values of the depths [Z ~> 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. @@ -247,22 +247,22 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) ! Read iEdit, jEdit and zEdit 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 read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid, scale=US%m_to_Z) call close_file_to_read(ncid, topo_edits_file) do n = 1, n_edits i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 j = jg(n) - G%jsd_global + 2 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then - if (new_depth(n)*US%m_to_Z /= mask_depth) then + if (new_depth(n) /= mask_depth) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(new_depth(n)), i, j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(US%Z_to_m*new_depth(n)), i, j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else if (topo_edits_change_mask) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(new_depth(n)),i,j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(US%Z_to_m*new_depth(n)),i,j + D(i,j) = abs(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)) @@ -454,8 +454,8 @@ subroutine set_rotation_planetary(f, G, param_file, US) call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") call get_param(param_file, "set_rotation_planetary", "OMEGA", omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) PI = 4.0*atan(1.0) do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB @@ -893,13 +893,13 @@ subroutine reset_face_lengths_list(G, param_file, US) allocate(v_line_used(num_lines), source=0) allocate(v_line_no(num_lines), source=0) - allocate(Dmin_u(num_lines)) ; Dmin_u(:) = 0.0 - allocate(Dmax_u(num_lines)) ; Dmax_u(:) = 0.0 - allocate(Davg_u(num_lines)) ; Davg_u(:) = 0.0 + allocate(Dmin_u(num_lines), source=0.0) + allocate(Dmax_u(num_lines), source=0.0) + allocate(Davg_u(num_lines), source=0.0) - allocate(Dmin_v(num_lines)) ; Dmin_v(:) = 0.0 - allocate(Dmax_v(num_lines)) ; Dmax_v(:) = 0.0 - allocate(Davg_v(num_lines)) ; Davg_v(:) = 0.0 + allocate(Dmin_v(num_lines), source=0.0) + allocate(Dmax_v(num_lines), source=0.0) + allocate(Davg_v(num_lines), source=0.0) ! Actually read the lines. if (is_root_pe()) then From c626cc46453c26e499d88fd48c7c616a0d81b9b6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:53:35 -0400 Subject: [PATCH 081/155] MOM_internal_tides diagnostic code simplification Replaced a call to global_area_mean with a call to global_area_integral in a diagnostic calculation in the internal_tides module. Also added descriptions of the dimensions of a number of variables in this module, or eliminated the dimension description of several integers (for which units make no sense). Only an unused debugging diagnostic is changed, and all solutions are bitwise identical. --- .../lateral/MOM_internal_tides.F90 | 41 +++++++++---------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 9efb455854..c426b20a6a 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -18,15 +18,13 @@ module MOM_internal_tides use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart -use MOM_spatial_means, only : global_area_mean +use MOM_spatial_means, only : global_area_integral use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS -!use, intrinsic :: IEEE_ARITHMETIC - implicit none ; private #include @@ -52,11 +50,11 @@ module MOM_internal_tides logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. real, allocatable, dimension(:,:) :: refl_angle - !< local coastline/ridge/shelf angles read from file + !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) - real :: nullangle = -999.9 !< placeholder value in cells with no reflection + real :: nullangle = -999.9 !< placeholder value in cells with no reflection [rad] real, allocatable, dimension(:,:) :: refl_pref - !< partial reflection coeff for each "coast cell" + !< partial reflection coeff for each "coast cell" [nondim] ! (could be in G control structure) logical, allocatable, dimension(:,:) :: refl_pref_logical !< true if reflecting cell with partial reflection @@ -98,11 +96,11 @@ module MOM_internal_tides real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging [R Z3 T-2 ~> J m-2] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. character(len=200) :: inputdir !< directory to look for coastline angle file real :: decay_rate !< A constant rate at which internal tide energy is - !! lost to the interior ocean internal wave field. + !! lost to the interior ocean internal wave field [T-1 ~> s-1]. real :: cdrag !< The bottom drag coefficient [nondim]. real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when @@ -537,7 +535,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Check for energy conservation on computational domain.************************* do m=1,CS%NMode ; do fr=1,CS%Nfreq - call sum_En(G,CS,CS%En(:,:,:,fr,m),'prop_int_tide') + call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') enddo ; enddo ! Output diagnostics.************************************************************ @@ -647,25 +645,23 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, CS, En, label) +subroutine sum_En(G, US, CS, En, label) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables - real :: En_sum ! The total energy [R Z3 T-2 ~> J m-2] - real :: tmpForSumming + real :: En_sum ! The total energy in MKS units for potential output [J] integer :: m,fr,a ! real :: En_sum_diff, En_sum_pdiff ! character(len=160) :: mesg ! The text of an error message ! real :: days En_sum = 0.0 - tmpForSumming = 0.0 do a=1,CS%nAngle - tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global - En_sum = En_sum + tmpForSumming + En_sum = En_sum + global_area_integral(En(:,:,a), G, scale=US%RZ3_T3_to_W_m2*US%T_to_s) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -1143,7 +1139,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_x') + !call sum_En(G, US, CS, En, 'post-propagate_x') ! Update halos call pass_var(En, G%domain) @@ -1155,7 +1151,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_y') + !call sum_En(G, US, CS, En, 'post-propagate_y') endif end subroutine propagate @@ -1712,6 +1708,7 @@ subroutine reflect(En, NAngle, CS, G, LB) !! [R Z3 T-2 ~> J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c ! angle of boundary wrt equator [rad] @@ -1724,11 +1721,11 @@ subroutine reflect(En, NAngle, CS, G, LB) real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] - integer :: angle_wall ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_wall0 ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_r ! angle of reflected ray wrt equator [nondim] - integer :: angle_r0 ! angle of reflected ray wrt equator [nondim] - integer :: angle_to_wall ! angle relative to wall [nondim] + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall integer :: a, a0 ! loop index for angles integer :: i, j, i_global integer :: Nangle_d2 ! Nangle / 2 From 6bfd073b25d616e8a130ad4d86b6c7138e589112 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:54:35 -0400 Subject: [PATCH 082/155] +Avoid nonsensical units descriptions Eliminated units arguments for logical, integer, or character string get_param calls where the units make no sense. In some other cases, calls were slightly revised to place the units and scale arguments on the same line for easier detection of inconsistent settings. All answers are bitwise identical, but the MOM_parameter_doc.all files for some test cases are corrected. --- .../MOM_state_initialization.F90 | 2 +- src/user/Idealized_Hurricane.F90 | 24 ++++--- src/user/MOM_wave_interface.F90 | 64 +++++++++---------- src/user/SCM_CVMix_tests.F90 | 53 +++++++-------- 4 files changed, 64 insertions(+), 79 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index d337e039e2..4e8dd4f186 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1179,7 +1179,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & "The initial condition variable for the surface pressure exerted by ice.", & - units="Pa", default="", do_not_log=just_read) + default="", do_not_log=just_read) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) filename = trim(slasher(inputdir))//trim(p_surf_file) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 707a0972f9..d067b76eff 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -133,8 +133,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) units='Pa', default=96800., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & CS%rad_max_wind, "Radius of maximum winds used in the "//& - "idealized hurricane wind profile.", units='m', & - default=50.e3, scale=US%m_to_L) + "idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & "Maximum wind speed used in the idealized hurricane"// & "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) @@ -143,8 +143,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& - "idealized hurricane wind profile.", units='degrees', & - default=180.0, scale=CS%Deg2Rad) + "idealized hurricane wind profile.", & + units='degrees', default=180.0, scale=CS%Deg2Rad) call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & "Idealized Hurricane initial X position", & units='m', default=0., scale=US%m_to_L) @@ -152,19 +152,17 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Idealized Hurricane initial Y position", & units='m', default=0., scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & - "Current relative stress switch "//& - "used in the idealized hurricane wind profile.", & - units='', default=.false.) + "Current relative stress switch used in the idealized hurricane wind profile.", & + default=.false.) ! Parameters for SCM mode call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & "Single column mode benchmark case switch, which is "// & "invoking a modification (bug) in the wind profile meant to "//& - "reproduce a previous implementation.", units='', default=.false.) + "reproduce a previous implementation.", default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & - "Single Column mode switch "//& - "used in the SCM idealized hurricane wind profile.", & - units='', default=.false.) + "Single Column mode switch used in the SCM idealized hurricane wind profile.", & + default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & "Y distance of station used in the SCM idealized hurricane "//& "wind profile.", units='m', default=50.e3, scale=US%m_to_L) @@ -186,8 +184,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & - "The background gustiness in the winds.", units="Pa", & - default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, do_not_log=.true.) if (CS%BR_BENCH) then CS%rho_a = 1.2*US%kg_m3_to_R diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a26bca4711..3077d81bb2 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -241,10 +241,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call log_version(param_file, mdl, version) ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) if (StatisticalWaves) then CS%WaveMethod = LF17 @@ -256,25 +256,25 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Wave modified physics ! Presently these are all in research mode call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & - "Flag to use Lagrangian Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Lagrangian Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%LagrangianMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & - "Flag to use Stokes Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Stokes Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%StokesMixing) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & - "Flag to use Coriolis Stokes acceleration", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Coriolis Stokes acceleration", default=.false., & + do_not_log=.not.use_waves) if (CS%CoriolisStokes) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Coriolis-Stokes? Code not ready.") endif ! Get Wave Method and write to integer WaveMethod @@ -293,7 +293,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) " directly from WW3 and is based on the \n"// & " surface layer and projected Langmuir \n"// & " number (Li 2016)\n", & - units='', default=NULL_STRING) + default=NULL_STRING) select case (TRIM(TMPSTRING1)) case (NULL_STRING)! No Waves call MOM_error(FATAL, "wave_interface_init called with no specified "//& @@ -311,12 +311,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands CS%WaveMethod = SURFBANDS - call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & - "Choice of SURFACE_BANDS data mode, valid options include: \n"// & - " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"// & - " COUPLER - Look for variables from coupler pass \n"// & - " INPUT - Testing with fixed values.", & - units='', default=NULL_STRING) + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & + "Choice of SURFACE_BANDS data mode, valid options include: \n"//& + " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& + " COUPLER - Look for variables from coupler pass \n"//& + " INPUT - Testing with fixed values.", default=NULL_STRING) select case (TRIM(TMPSTRING2)) case (NULL_STRING)! Default call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& @@ -328,10 +327,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) case (COUPLER_STRING)! Reserved for coupling CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. - 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) + 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.", default=1) allocate( CS%WaveNum_Cen(CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) @@ -341,11 +340,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='rad/m', default=0.12566, scale=US%Z_to_m) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) CS%DataSource = INPUT - 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) + 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.", default=1) allocate( CS%WaveNum_Cen(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkX(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) @@ -370,17 +368,15 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& " Stokes drift in x-direction.") call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & - "Choose true to use waveage in peak frequency.", & - units='', default=.false.) + "Choose true to use waveage in peak frequency.", default=.false.) call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND", CS%WaveWind, & + call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl,"STATIC_DHH85", CS%StaticWaves, & - "Flag to disable updating DHH85 Stokes drift.", & - default=.false.) + call get_param(param_file, mdl, "STATIC_DHH85", CS%StaticWaves, & + "Flag to disable updating DHH85 Stokes drift.", default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 case (EFACTOR_STRING)!Li and Fox-Kemper 16 diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 5bbe65b8d8..74cf31a22b 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -143,48 +143,39 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", & - CS%UseWindStress, "Wind Stress switch "// & - "used in the SCM CVMix surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", & - CS%UseHeatFlux, "Heat flux switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_EVAPORATION", & - CS%UseEvaporation, "Evaporation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", & - CS%UseDiurnalSW, "Diurnal sw radation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) + call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", CS%UseWindStress, & + "Wind Stress switch used in the SCM CVMix surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", CS%UseHeatFlux, & + "Heat flux switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_EVAPORATION", CS%UseEvaporation, & + "Evaporation switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", CS%UseDiurnalSW, & + "Diurnal sw radation switch used in the SCM CVMix test surface forcing.", & + default=.false.) if (CS%UseWindStress) then - call get_param(param_file, mdl, "SCM_TAU_X", & - CS%tau_x, "Constant X-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_X", CS%tau_x, & + "Constant X-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "SCM_TAU_Y", & - CS%tau_y, "Constant y-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_Y", CS%tau_y, & + "Constant y-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) endif if (CS%UseHeatFlux) then - call get_param(param_file, mdl, "SCM_HEAT_FLUX", & - CS%surf_HF, "Constant surface heat flux "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_HEAT_FLUX", CS%surf_HF, & + "Constant surface heat flux used in the SCM CVMix test surface forcing.", & units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseEvaporation) then - call get_param(param_file, mdl, "SCM_EVAPORATION", & - CS%surf_evap, "Constant surface evaporation "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_EVAPORATION", CS%surf_evap, & + "Constant surface evaporation used in the SCM CVMix test surface forcing.", & units='m/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseDiurnalSW) then - call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", & - CS%Max_sw, "Maximum diurnal sw radiation "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", CS%Max_sw, & + "Maximum diurnal sw radiation used in the SCM CVMix test surface forcing.", & units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif call get_param(param_file, mdl, "RHO_0", CS%Rho0, & From 063ef75faf1aadf07c9a1732641b81397b231aa1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:55:03 -0400 Subject: [PATCH 083/155] Minor get_param call reformatting Revised get_param calls to put the units and scale arguments on the same line, to help detect inconsistent settings. All answers and output are bitwise identical. --- src/user/Phillips_initialization.F90 | 4 ++-- src/user/external_gwave_initialization.F90 | 4 ++-- src/user/user_change_diffusivity.F90 | 7 +++---- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index db1b512ca9..7f958cfb7e 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -265,8 +265,8 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The fractional depth where the stratificaiton is centered.", & units="nondim", default = 0.5) call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & - "The rate at which the zonal-mean sponges damp.", units="s-1", & - default = 1.0/(10.0*86400.0), scale=US%T_to_s) + "The rate at which the zonal-mean sponges damp.", & + units="s-1", default = 1.0/(10.0*86400.0), scale=US%T_to_s) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 27d0cedded..ec507e181b 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -53,8 +53,8 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SSH_ANOMALY_HEIGHT", ssh_anomaly_height, & - "The vertical displacement of the SSH anomaly. ", units="m", & - fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) + "The vertical displacement of the SSH anomaly. ", units="m", scale=US%m_to_Z, & + fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "SSH_ANOMALY_WIDTH", ssh_anomaly_width, & "The lateral width of the SSH anomaly. ", units="coordinate", & fail_if_missing=.not.just_read, do_not_log=just_read) diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 0308a3b008..3f276a1dd0 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -205,8 +205,8 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) !! point to the control !! structure for this module. -! 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 = "user_set_diffusivity" ! This module's name. character(len=200) :: mesg integer :: i, j, is, ie, js, je @@ -228,8 +228,7 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & "A user-specified additional diffusivity over a range of "//& - "latitude and density.", default=0.0, units="m2 s-1", & - scale=US%m2_s_to_Z2_T) + "latitude and density.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & "Four successive values that define a range of latitudes "//& From db59e142d5f2e203e119eaffbbf3f8de2cd6ca72 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:55:26 -0400 Subject: [PATCH 084/155] MOM_neutral_diffusion code cleanup Eliminated a commented-out get_param call and use a source argument to initialize some arrays. All answers and output are bitwise identical. --- src/tracer/MOM_neutral_diffusion.F90 | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index fd479eeaf3..1a80829255 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -244,9 +244,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 -! call get_param(param_file, mdl, "KHTR", CS%KhTr, & -! "The background along-isopycnal tracer diffusivity.", & -! units="m2 s-1", default=0.0) ! call closeParameterBlock(param_file) if (CS%continuous_reconstruction) then CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections @@ -269,17 +266,17 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(GV)), source=.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. - allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%uHeff(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 + allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) ! V-points - allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%vHeff(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 + allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) end function neutral_diffusion_init @@ -577,7 +574,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) integer :: i, j, k, m, ks, nk real :: Idt ! The inverse of the time step [T-1 ~> s-1] - real :: h_neglect, h_neglect_edge + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff From edd3f9c68bcc910a186798fb6d5212b41e1328c9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 26 Mar 2022 11:56:14 -0400 Subject: [PATCH 085/155] +Corrected units in dumbbell get_param calls Corrected the units in some get_param calls in the dumbbell test case. All answers are bitwise identical, but there will be minor changes in the MOM_parameter_doc files for the dumbbell test case. --- src/user/dumbbell_initialization.F90 | 42 +++++++++++++-------------- src/user/dumbbell_surface_forcing.F90 | 2 +- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index ac4181d570..20beebc67f 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -51,10 +51,10 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) real :: x, y, delta, dblen, dbfrac logical :: dbrotate - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + call get_param(param_file, mdl, "DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell.',& - units='k', default=600., do_not_log=.false.) - call get_param(param_file, mdl,"DUMBBELL_FRACTION",dbfrac, & + units='km', default=600., do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_FRACTION",dbfrac, & 'Meridional fraction for narrow part of dumbbell.',& units='nondim', default=0.5, do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & @@ -141,8 +141,8 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl,"INITIAL_SSS", S_surf, default=34., do_not_log=.true.) - call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, default=34., do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) @@ -230,23 +230,23 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & + call get_param(param_file, mdl, "INITIAL_DENSITY_PROFILE", density_profile, & 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & + call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_S_RANGE", S_range, & - 'DUMBBELL salinity range (right-left)', units='1e-3', & - default=2., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', units='1e-3', default=2., & + do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell ', & + units='km', default=600., do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & - 'Logical for rotation of dumbbell domain.',& + 'Logical for rotation of dumbbell domain.', & units='nondim', default=.false., do_not_log=just_read) if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + dblen = dblen*1.e3 endif do j=G%jsc,G%jec @@ -259,16 +259,16 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file x = ( G%geoLonT(i,j) ) / dblen endif do k=1,nz - T(i,j,k)=T_surf + T(i,j,k) = T_surf enddo if (x>=0. ) then do k=1,nz - S(i,j,k)=S_surf + 0.5*S_range + S(i,j,k) = S_surf + 0.5*S_range enddo endif if (x<0. ) then do k=1,nz - S(i,j,k)=S_surf - 0.5*S_range + S(i,j,k) = S_surf - 0.5*S_range enddo endif @@ -303,7 +303,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=.true.) + units='km', default=600., do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& units='nondim', default=.false., do_not_log=.true.) @@ -378,12 +378,12 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use endif if (x>=0.25 ) then do k=1,nz - S(i,j,k)=S_ref + 0.5*S_range + S(i,j,k) = S_ref + 0.5*S_range enddo endif if (x<=-0.25 ) then do k=1,nz - S(i,j,k)=S_ref - 0.5*S_range + S(i,j,k) = S_ref - 0.5*S_range enddo endif enddo ; enddo diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index a1d8bf4b52..8c980edc8e 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -215,7 +215,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) units="Pa", default = 10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & - units="days", default = 1.0) + units="days", default=1.0) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& units='nondim', default=.false., do_not_log=.true.) From 78c574be1d35eed7787752fe448091122d136610 Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Mon, 4 Apr 2022 05:31:51 -0600 Subject: [PATCH 086/155] Add missing h_neglect (#98) Co-authored-by: Robert Hallberg --- src/core/MOM_isopycnal_slopes.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 80d94ec7fe..acd31c2091 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -257,7 +257,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect From e853f839bed28ad8a8c86f94e5d7669bcda6a419 Mon Sep 17 00:00:00 2001 From: Philip Pegion Date: Tue, 5 May 2020 09:41:38 -0500 Subject: [PATCH 087/155] additions for stochastic physics and ePBL perts --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 + src/core/MOM.F90 | 39 +++++++++--- src/core/MOM_forcing_type.F90 | 19 ++++-- src/diagnostics/MOM_diagnostics.F90 | 22 +++++-- src/framework/MOM_domains.F90 | 59 ++++--------------- .../vertical/MOM_energetic_PBL.F90 | 2 +- 6 files changed, 79 insertions(+), 64 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index c704214930..10add0f8d0 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -315,6 +315,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + print*,'allocate fluxes%t_rp' + call safe_alloc_ptr(fluxes%t_rp,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then fluxes%p_surf_SSH => fluxes%p_surf else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f3d8869320..f3ce4f3b11 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -30,6 +30,7 @@ module MOM 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 use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners +use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -155,8 +156,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, initialize_ice_shelf -use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end +use stochastic_physics, only : init_stochastic_physics_ocn,run_stochastic_physics_ocn implicit none ; private @@ -249,6 +249,8 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode + logical :: do_stochy = .false. + !< If true, call stochastic physics pattern generator type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [T ~> s] @@ -827,6 +829,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + print*,'calling run_stochastic_physics_ocn',CS%do_stochy + if (CS%do_stochy) call run_stochastic_physics_ocn(forces%t_rp) call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & @@ -979,7 +983,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & - sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) + sfc_state, CS%tv, ssh, fluxes%t_rp, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1812,10 +1816,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - real :: conv2watt ! A conversion factor from temperature fluxes to heat - ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] - real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] - real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors + integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer :: num_procs +! model + integer :: me ! my pe + integer :: master ! root pe + real :: conv2watt, conv2salt character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -2492,6 +2498,25 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif + ! Shift from using the temporary dynamic grid type to using the final + ! (potentially static) ocean-specific grid type. + ! The next line would be needed if G%Domain had not already been init'd above: + ! call clone_MOM_domain(dG%Domain, G%Domain) + call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG, G, US) + call destroy_dyn_horgrid(dG) + + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist) + me=PE_here() + master=root_PE() + + !call init_stochastic_physics_ocn(CS%dt_therm,G,me,master,pelist,CS%do_stochy) + print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) + call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,CS%do_stochy) + print*,'back from init_stochastic_physics_ocn',CS%do_stochy + ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index bdf4823f81..8bbcb9854d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,6 +145,8 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. + real, pointer, dimension(:,:) :: t_rp => NULL() + !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -250,10 +252,10 @@ module MOM_forcing_type !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, !! and is exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: & - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at - !! u-points [L4 Z-1 T-1 ~> m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at - !! v-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] + real, pointer, dimension(:,:) :: t_rp => NULL() + !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2135,6 +2137,12 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres + if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then + do j=js,je ; do i=is,ie + fluxes%t_rp(i,j) = forces%t_rp(i,j) + enddo ; enddo + endif + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) @@ -3109,6 +3117,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) + call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3273,6 +3282,7 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) + if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3303,6 +3313,7 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) + if (associated(forces%t_rp)) deallocate(forces%t_rp) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ef71d9286c..ddb925af28 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,7 +139,9 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - !>@} +! stochastic pattern + integer :: id_t_rp = -1 + !!@} end type surface_diag_IDs @@ -1277,7 +1279,7 @@ end subroutine post_surface_dyn_diags !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & - ssh, ssh_ibc) + ssh, t_rp, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1286,8 +1288,10 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> s]. type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< Time mean surface height without corrections - !! for ice displacement [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: t_rp!< random pattern for stochastic proceeses real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] @@ -1409,6 +1413,11 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif + if (IDs%id_t_rp > 0) then + !call post_data(IDs%id_t_rp, t_rp, diag, mask=G%mask2dT) + call post_data(IDs%id_t_rp, t_rp, diag) + endif + call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) end subroutine post_surface_thermo_diags @@ -1896,8 +1905,9 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', & - 'W m-2', conversion=US%QRZ_T_to_W_m2) + 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') + IDs%id_t_rp = register_diag_field('ocean_model', 'random_pattern', diag%axesT1, Time, & + 'random pattern for stochastics', 'None') end subroutine register_surface_diags diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index dc6c0a8996..b647c56534 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,56 +3,23 @@ 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_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 : get_domain_extent, get_domain_components, same_domain -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 -use MOM_domain_infra, only : start_group_pass, complete_group_pass -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 -use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io_infra, only : file_exists +use MOM_coms, only : PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end, Get_PElist +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_string_functions, only : slasher implicit none ; private -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 -public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! Domain query routines -public :: get_domain_extent, get_domain_components, get_global_shape, same_domain -public :: PE_here, root_PE, num_PEs -! Blocks are not actively used in MOM6, so this routine could be deprecated. -public :: compute_block_extent -! 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 :: 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 -public :: CORNER, CENTER, NORTH_FACE, EAST_FACE -!> These encoding constants indicate communication patterns. In practice they can be added. +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 :: pass_var, pass_vector, PE_here, root_PE, num_PEs, Get_PElist +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, CORNER, CENTER 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. diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..c9ae6e43ed 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -401,7 +401,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j) + u_star = fluxes%ustar(i,j)*(fluxes%t_rp(i,j)) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then From 45acf37f19176c583b364b1caf069d819f91e3b1 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 2 Dec 2020 15:35:05 +0000 Subject: [PATCH 088/155] cleanup of code and enhancement of ePBL perts --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 - src/core/MOM.F90 | 28 +-- src/core/MOM_forcing_type.F90 | 43 +++-- src/diagnostics/MOM_diagnostics.F90 | 16 +- .../vertical/MOM_diabatic_driver.F90 | 174 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 62 ++++--- 6 files changed, 172 insertions(+), 153 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 10add0f8d0..c704214930 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -315,8 +315,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) - print*,'allocate fluxes%t_rp' - call safe_alloc_ptr(fluxes%t_rp,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then fluxes%p_surf_SSH => fluxes%p_surf else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f3ce4f3b11..b421955863 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -156,7 +156,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 stochastic_physics, only : init_stochastic_physics_ocn,run_stochastic_physics_ocn +use stochastic_physics, only : init_stochastic_physics_ocn implicit none ; private @@ -829,9 +829,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif - print*,'calling run_stochastic_physics_ocn',CS%do_stochy - if (CS%do_stochy) call run_stochastic_physics_ocn(forces%t_rp) - call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & Time_local, Waves=Waves) @@ -983,7 +980,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & - sfc_state, CS%tv, ssh, fluxes%t_rp, CS%ave_ssh_ibc) + sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) + !sfc_state_diag, CS%tv, ssh,fluxes%t_rp,fluxes%sppt_wts, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1810,6 +1808,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic ! time step needs to be updated before it is used. logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. + logical :: do_epbl,do_sppt integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. @@ -1817,7 +1816,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: num_procs + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs,iret ! model integer :: me ! my pe integer :: master ! root pe @@ -2508,14 +2508,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & num_procs=num_PEs() allocate(pelist(num_procs)) - call Get_PElist(pelist) + call Get_PElist(pelist,commID = mom_comm) me=PE_here() master=root_PE() - !call init_stochastic_physics_ocn(CS%dt_therm,G,me,master,pelist,CS%do_stochy) - print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,CS%do_stochy) - print*,'back from init_stochastic_physics_ocn',CS%do_stochy + !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) + do_epbl=.false. + do_sppt=.false. + call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) + if (do_sppt .eq. .true.) CS%do_stochy=.true. + if (do_epbl .eq. .true.) CS%do_stochy=.true. + !print*,'back from init_stochastic_physics_ocn',CS%do_stochy ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then @@ -2968,6 +2971,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! call fix_restart_scaling(GV) ! call fix_restart_unit_scaling(US) + CS%diabatic_CSp%do_epbl=do_epbl + CS%diabatic_CSp%do_sppt=do_sppt + call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 8bbcb9854d..3351a6eee1 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,8 +145,10 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. - real, pointer, dimension(:,:) :: t_rp => NULL() - !< random pattern at t-points +! real, pointer, dimension(:,:) :: t_rp => NULL() +! !< random pattern at t-points +! real, pointer, dimension(:,:) :: sppt_wts => NULL() +! !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -252,10 +254,14 @@ module MOM_forcing_type !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, !! and is exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: & - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] - real, pointer, dimension(:,:) :: t_rp => NULL() - !< random pattern at t-points + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! u-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! v-points [L4 Z-1 T-1 ~> m3 s-1] +! real, pointer, dimension(:,:) :: t_rp => NULL() +! !< random pattern at t-points +! real, pointer, dimension(:,:) :: sppt_wts => NULL() +! !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2137,11 +2143,17 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres - if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then - do j=js,je ; do i=is,ie - fluxes%t_rp(i,j) = forces%t_rp(i,j) - enddo ; enddo - endif +! if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then +! do j=js,je ; do i=is,ie +! fluxes%t_rp(i,j) = forces%t_rp(i,j) +! enddo ; enddo +! endif +! +! if (associated(forces%sppt_wts) .and. associated(fluxes%sppt_wts)) then +! do j=js,je ; do i=is,ie +! fluxes%sppt_wts(i,j) = forces%sppt_wts(i,j) +! enddo ; enddo +! endif if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie @@ -3117,7 +3129,8 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) - call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) +! call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) +! call myAlloc(forces%sppt_wts,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3282,7 +3295,8 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) - if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) +! if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) +! if (associated(fluxes%sppt_wts)) deallocate(fluxes%sppt_wts) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3313,7 +3327,8 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) - if (associated(forces%t_rp)) deallocate(forces%t_rp) +! if (associated(forces%t_rp)) deallocate(forces%t_rp) +! if (associated(forces%sppt_wts)) deallocate(forces%sppt_wts) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ddb925af28..221b5b7ebf 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,8 +139,6 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 -! stochastic pattern - integer :: id_t_rp = -1 !!@} end type surface_diag_IDs @@ -1279,7 +1277,7 @@ end subroutine post_surface_dyn_diags !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & - ssh, t_rp, ssh_ibc) + ssh, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1290,8 +1288,6 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: t_rp!< random pattern for stochastic proceeses real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] @@ -1413,11 +1409,6 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif - if (IDs%id_t_rp > 0) then - !call post_data(IDs%id_t_rp, t_rp, diag, mask=G%mask2dT) - call post_data(IDs%id_t_rp, t_rp, diag) - endif - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) end subroutine post_surface_thermo_diags @@ -1905,9 +1896,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - IDs%id_t_rp = register_diag_field('ocean_model', 'random_pattern', diag%axesT1, Time, & - 'random pattern for stochastics', 'None') + 'Heat flux into ocean from geothermal or other internal sources', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) end subroutine register_surface_diags diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7b180f1d65..1e7611de19 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,7 +69,8 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS -use MOM_stochastics, only : stochastic_CS +use stochastic_physics, only : run_stochastic_physics_ocn + implicit none ; private @@ -175,20 +176,15 @@ module MOM_diabatic_driver real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds - integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic - integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 - integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 - integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 - ! These are handles to diagnostics related to the mixed layer properties. - integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 - - ! These are handles to diatgnostics that are only available in non-ALE layered mode. - integer :: id_wd = -1 - integer :: id_dudt_dia = -1, id_dvdt_dia = -1 - integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 + integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) + integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) + integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_ea_t = -1, id_eb_t = -1 + integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 + integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 + integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_subMLN2 = -1, id_brine_lay = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -220,6 +216,10 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics + logical,public :: do_epbl = .false. !< If true pertrub u_start in ePBL calculation + logical,public :: do_sppt = .false. !< If true perturb all physics tendenceies in MOM_diabatic_driver + real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil + real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module @@ -303,31 +303,36 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics + real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts + real, dimension(SZI_(G),SZJ_(G),2) :: t_rp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT + real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT if (G%ke == 1) return - ! save copy of the date for SPPT if active - if (stoch_CS%do_sppt) then - allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) - - if (stoch_CS%id_sppt_wts > 0) then - call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) - endif + ! save copy of the date for SPPT + if (CS%do_sppt) then + h_in=h + t_in=tv%T + s_in=tv%S + endif + call run_stochastic_physics_ocn(t_rp,sppt_wts) + !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) + !print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + if (CS%id_t_rp1 > 0) then + call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) + endif + if (CS%id_t_rp2 > 0) then + call post_data(CS%id_t_rp2, t_rp(:,:,2), CS%diag) + endif + if (CS%id_sppt_wts > 0) then + call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) endif - if (GV%ke == 1) return - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") @@ -411,11 +416,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) + call diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -481,55 +486,53 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stoch_CS%do_sppt) then - ! perturb diabatic tendecies + if (CS%do_sppt) then do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) if (h_pert > GV%Angstrom_H) then - h(i,j,k) = h_pert + h(i,j,k)=h_pert else - h(i,j,k) = GV%Angstrom_H + h(i,j,k)=GV%Angstrom_H endif - tv%T(i,j,k) = t_pert + tv%T(i,j,k)=t_pert if (s_pert > 0.0) then - tv%S(i,j,k) = s_pert + tv%S(i,j,k)=s_pert endif enddo enddo enddo - deallocate(h_in) - deallocate(t_in) - deallocate(s_in) endif end subroutine diabatic +end subroutine diabatic + !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -837,8 +840,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -1100,22 +1103,22 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -1374,8 +1377,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -3137,11 +3140,16 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & - call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) - if ((CS%id_dvdt_dia > 0) .or. (CS%id_hf_dvdt_dia_2d > 0)) & - call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) - endif + CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & + 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & + 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + 'random pattern1 for stochastics', 'None') + CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + 'random pattern2 for stochastics', 'None') + CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & + 'random pattern for sppt', 'None') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index c9ae6e43ed..ffa942b03a 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -165,6 +165,7 @@ module MOM_energetic_PBL !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in !! upward or downward passes. + logical :: do_epbl type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the !! timing of diagnostic output. @@ -244,8 +245,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, US, CS, & + dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & + dT_expected, dS_expected, Waves ) 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 @@ -277,8 +279,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + !! [Z2 s-1 ~> m2 s-1]. + type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous + !! call to mixedlayer_init. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: t_rp !< random pattern to perturb wind real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -401,7 +406,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j)*(fluxes%t_rp(i,j)) + !print*,'PJP EPBL',minval(t_rp),maxval(t_rp) + u_star = fluxes%ustar(i,j)!*t_rp(i,j) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then @@ -423,16 +429,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, Waves, G, i, j, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) - else - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, Waves, G, i, j) - endif + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + + ! applly stochastic perturbation to TKE generation ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -500,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - Waves, G, i, j, epbl1_wt, epbl2_wt) + t_rp1,t_rp2, dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -537,12 +538,16 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation - integer, intent(in) :: i !< The i-index to work on (used for Waves) - integer, intent(in) :: j !< The i-index to work on (used for Waves) + real, intent(in) :: t_rp1 !< random value to perturb TKE production + real, intent(in) :: t_rp2 !< random value to perturb TKE production + real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less + !! than dt if there are two calls to mixedlayer [T ~> s]. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Wave CS for Langmuir turbulence + type(ocean_grid_type), & + optional, intent(inout) :: G !< The ocean's grid structure. + integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) + integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) ! This subroutine determines the diffusivities in a single column from the integrated energetics ! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes @@ -831,8 +836,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE in the UFS - if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt + ! stochastically pertrub mech_TKE + mech_TKE=mech_TKE*t_rp1 if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -914,12 +919,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & - eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) - else - mech_TKE = mech_TKE * exp_kh - endif + !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + eCD%dTKE_mech_decay = exp_kh + mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From b6ac287b6f6e134a700e65bbad146d65b42553a8 Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:03:36 -0700 Subject: [PATCH 089/155] Update MOM_diabatic_driver.F90 remove conflict with dev/emc --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1e7611de19..a9d3a63b15 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_brine_lay = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From 2f5d83d3c0f9fc3c3c2e8c12bf292e2624604548 Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:05:28 -0700 Subject: [PATCH 090/155] Update MOM_diabatic_driver.F90 further resolve conflict --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a9d3a63b15..654ad8615d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From cefdb81edbeca418d33930bc9a9e630e52e4cff3 Mon Sep 17 00:00:00 2001 From: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Date: Wed, 2 Dec 2020 09:06:52 -0700 Subject: [PATCH 091/155] Update MOM_diabatic_driver.F90 put id_sppt_wts, etc back. --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 654ad8615d..a9d3a63b15 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 From 6ff36ec6d6527b96a4623bb03b812e9724b5fed4 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 14 Dec 2020 15:47:16 +0000 Subject: [PATCH 092/155] add stochy_restart writing to mom_cap --- config_src/drivers/nuopc_cap/mom_cap.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 174a659f12..0434103b5a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,6 +97,7 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM +use get_stochy_pattern_mod, only: write_stoch_restart_ocn !$use omp_lib , only : omp_set_num_threads @@ -1749,9 +1750,17 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname, & - stoch_restartname=stoch_restartname) + call ocean_model_restart(ocean_state, restartname=restartname) + ! write stochastic physics restart file if active + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"ocn_stoch.res.nc") + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + "oc_stoch.res.", year, month, day, hour, minute, seconds,".nc" + endif + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + call write_stoch_restart_ocn('RESTART/'//trim(timestamp)//'.ocn_stoch.res.nc') endif if (is_root_pe()) then From 095c36ca4125fca7e98cb11f740292701e8761fa Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 22 Dec 2020 18:40:13 +0000 Subject: [PATCH 093/155] additions for stochy restarts --- config_src/drivers/nuopc_cap/mom_cap.F90 | 11 ++++++++--- config_src/drivers/solo_driver/MOM_driver.F90 | 16 ++++++++++++++++ src/core/MOM.F90 | 14 +++++++------- .../vertical/MOM_diabatic_driver.F90 | 16 +++++++++++++--- .../vertical/MOM_energetic_PBL.F90 | 19 ++++++++++--------- 5 files changed, 54 insertions(+), 22 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 0434103b5a..b298270d17 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,7 +97,9 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM +#ifdef UFS use get_stochy_pattern_mod, only: write_stoch_restart_ocn +#endif !$use omp_lib , only : omp_set_num_threads @@ -1753,14 +1755,17 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname) ! write stochastic physics restart file if active +#ifdef UFS if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc") + write(restartname,'(A)')"ocn_stoch.res.nc" else write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "oc_stoch.res.", year, month, day, hour, minute, seconds,".nc" + "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - call write_stoch_restart_ocn('RESTART/'//trim(timestamp)//'.ocn_stoch.res.nc') + if (is_root_pe()) print*,'calling write_stoch_restart_ocn ',trim(restartname) + call write_stoch_restart_ocn('RESTART/'//trim(restartname)) +#endif endif if (is_root_pe()) then diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index c2cd0a248c..c706ed70b4 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -71,6 +71,22 @@ program MOM_main use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + 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 + use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart +! , add_shelf_flux_forcing, add_shelf_flux_IOB + + 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 +#ifdef UFS + use get_stochy_pattern_mod, only: write_stoch_restart_ocn +#endif + implicit none #include diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b421955863..f9cd435177 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -156,7 +156,9 @@ 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 +#ifdef UFS use stochastic_physics, only : init_stochastic_physics_ocn +#endif implicit none ; private @@ -249,8 +251,6 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode - logical :: do_stochy = .false. - !< If true, call stochastic physics pattern generator type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [T ~> s] @@ -2506,6 +2506,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call copy_dyngrid_to_MOM_grid(dG, G, US) call destroy_dyn_horgrid(dG) + do_epbl=.false. + do_sppt=.false. +#ifdef UFS num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) @@ -2513,12 +2516,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & master=root_PE() !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - do_epbl=.false. - do_sppt=.false. + if (master) print*,'about to call init_stochastic_physics' call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) - if (do_sppt .eq. .true.) CS%do_stochy=.true. - if (do_epbl .eq. .true.) CS%do_stochy=.true. - !print*,'back from init_stochastic_physics_ocn',CS%do_stochy +#endif ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a9d3a63b15..ffe5f3151a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,7 +69,9 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS +#ifdef UFS use stochastic_physics, only : run_stochastic_physics_ocn +#endif implicit none ; private @@ -305,23 +307,28 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts real, dimension(SZI_(G),SZJ_(G),2) :: t_rp +#ifdef UFS real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT +#endif if (G%ke == 1) return +#ifdef UFS ! save copy of the date for SPPT if (CS%do_sppt) then h_in=h t_in=tv%T s_in=tv%S endif + print*,'calling run_stochastic_physics' call run_stochastic_physics_ocn(t_rp,sppt_wts) !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) - !print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) + print*,'in diabatic',CS%do_sppt,minval(t_rp),maxval(t_rp) if (CS%id_t_rp1 > 0) then call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) endif @@ -331,6 +338,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_sppt_wts > 0) then call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) endif +#endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -486,6 +494,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) +#ifdef UFS if (CS%do_sppt) then do k=1,nz do j=js,je @@ -509,6 +518,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo endif +#endif end subroutine diabatic @@ -840,7 +850,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -1377,7 +1387,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index ffa942b03a..4f7fff1a05 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -245,7 +245,7 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & dT_expected, dS_expected, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -284,6 +284,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, !! call to mixedlayer_init. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: t_rp !< random pattern to perturb wind + logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -406,8 +407,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - !print*,'PJP EPBL',minval(t_rp),maxval(t_rp) - u_star = fluxes%ustar(i,j)!*t_rp(i,j) + u_star = fluxes%ustar(i,j) u_star_Mean = fluxes%ustar_gustless(i,j) B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then @@ -431,7 +431,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, dt, Kd_int, G, GV, call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) ! applly stochastic perturbation to TKE generation @@ -501,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - t_rp1,t_rp2, dt_diag, Waves, G, i, j) + t_rp1,t_rp2, stoch_epbl, dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -539,7 +539,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. real, intent(in) :: t_rp1 !< random value to perturb TKE production - real, intent(in) :: t_rp2 !< random value to perturb TKE production + real, intent(in) :: t_rp2 !< random value to perturb TKE dissipation + logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less !! than dt if there are two calls to mixedlayer [T ~> s]. type(wave_parameters_CS), & @@ -836,8 +837,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE - mech_TKE=mech_TKE*t_rp1 + ! stochastically pertrub mech_TKE in the UFS + if (stoch_epbl) mech_TKE=mech_TKE*t_rp1 if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -921,7 +922,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%TKE_diagnostics) & !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag eCD%dTKE_mech_decay = exp_kh - mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 878543d22fee46dd353e8f64ee85f84389824eac Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 23 Dec 2020 21:46:27 +0000 Subject: [PATCH 094/155] clean up debug statements --- config_src/drivers/nuopc_cap/mom_cap.F90 | 1 - config_src/drivers/solo_driver/MOM_driver.F90 | 3 --- src/core/MOM.F90 | 2 -- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ---- 4 files changed, 10 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b298270d17..8778df067a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1763,7 +1763,6 @@ subroutine ModelAdvance(gcomp, rc) "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - if (is_root_pe()) print*,'calling write_stoch_restart_ocn ',trim(restartname) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) #endif endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index c706ed70b4..c35caa9d38 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -83,9 +83,6 @@ program MOM_main 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 -#ifdef UFS - use get_stochy_pattern_mod, only: write_stoch_restart_ocn -#endif implicit none diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f9cd435177..dc6a5a7f1e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2515,8 +2515,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & me=PE_here() master=root_PE() - !print*,'callling init_stochastic_physics_ocn',maxval(G%geoLatT) - if (master) print*,'about to call init_stochastic_physics' call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) #endif diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index ffe5f3151a..856dd30f4e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -324,11 +324,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & t_in=tv%T s_in=tv%S endif - print*,'calling run_stochastic_physics' call run_stochastic_physics_ocn(t_rp,sppt_wts) - !print*,'in diabatic',CS%do_sppt,size(t_in,1),size(t_in,2),size(t_in,3),size(sppt_wts,1),size(sppt_wts,2) - print*,'in diabatic',CS%do_sppt,minval(sppt_wts),maxval(sppt_wts) - print*,'in diabatic',CS%do_sppt,minval(t_rp),maxval(t_rp) if (CS%id_t_rp1 > 0) then call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) endif From 583c6ae1e9ee6856ce9768cbee4e6d8827c53e63 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 6 Jan 2021 15:35:18 +0000 Subject: [PATCH 095/155] clean up code --- src/core/MOM.F90 | 7 +++-- src/core/MOM_forcing_type.F90 | 26 ------------------- src/diagnostics/MOM_diagnostics.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 6 ++--- 4 files changed, 6 insertions(+), 35 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index dc6a5a7f1e..bab2cf5a4a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -981,7 +981,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) - !sfc_state_diag, CS%tv, ssh,fluxes%t_rp,fluxes%sppt_wts, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1816,9 +1815,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs,iret -! model + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs ! number of processors to pass to stochastic physics + integer :: iret ! return code from stochastic physics integer :: me ! my pe integer :: master ! root pe real :: conv2watt, conv2salt diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3351a6eee1..bdf4823f81 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -145,10 +145,6 @@ module MOM_forcing_type !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. -! real, pointer, dimension(:,:) :: t_rp => NULL() -! !< random pattern at t-points -! real, pointer, dimension(:,:) :: sppt_wts => NULL() -! !< random pattern at t-points logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level @@ -258,10 +254,6 @@ module MOM_forcing_type !! u-points [L4 Z-1 T-1 ~> m3 s-1] rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at !! v-points [L4 Z-1 T-1 ~> m3 s-1] -! real, pointer, dimension(:,:) :: t_rp => NULL() -! !< random pattern at t-points -! real, pointer, dimension(:,:) :: sppt_wts => NULL() -! !< random pattern at t-points real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -2143,18 +2135,6 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres -! if (associated(forces%t_rp) .and. associated(fluxes%t_rp)) then -! do j=js,je ; do i=is,ie -! fluxes%t_rp(i,j) = forces%t_rp(i,j) -! enddo ; enddo -! endif -! -! if (associated(forces%sppt_wts) .and. associated(fluxes%sppt_wts)) then -! do j=js,je ; do i=is,ie -! fluxes%sppt_wts(i,j) = forces%sppt_wts(i,j) -! enddo ; enddo -! endif - if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) @@ -3129,8 +3109,6 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) -! call myAlloc(forces%t_rp,isd,ied,jsd,jed, press) -! call myAlloc(forces%sppt_wts,isd,ied,jsd,jed, press) call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) @@ -3295,8 +3273,6 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) -! if (associated(fluxes%t_rp)) deallocate(fluxes%t_rp) -! if (associated(fluxes%sppt_wts)) deallocate(fluxes%sppt_wts) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) @@ -3327,8 +3303,6 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%ustar)) deallocate(forces%ustar) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) -! if (associated(forces%t_rp)) deallocate(forces%t_rp) -! if (associated(forces%sppt_wts)) deallocate(forces%sppt_wts) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 221b5b7ebf..27164c2c75 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -139,7 +139,7 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - !!@} + !>@} end type surface_diag_IDs diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 4f7fff1a05..85dc52dd0e 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -433,8 +433,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) - ! applly stochastic perturbation to TKE generation - ! Copy the diffusivities to a 2-d array. do K=1,nz+1 Kd_2d(i,K) = Kd(K) @@ -920,8 +918,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & - !eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - eCD%dTKE_mech_decay = exp_kh + eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + mech_TKE = mech_TKE * exp_kh if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) ! Accumulate any convectively released potential energy to contribute From 48354da37c5e7601089f317947e7ba17a8299c32 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Thu, 7 Jan 2021 15:42:13 +0000 Subject: [PATCH 096/155] fix non stochastic ePBL calculation --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 85dc52dd0e..1cf089d5ed 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -919,8 +919,11 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - mech_TKE = mech_TKE * exp_kh - if (stoch_epbl) mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stoch_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + else + mech_TKE = mech_TKE * exp_kh + endif ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 390fee8d0cc1364bed2b9cc8ae9a6d9f7ea06799 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 29 Jan 2021 19:40:10 +0000 Subject: [PATCH 097/155] re-write of stochastic code to remove CPP directives --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 15 +-- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 15 +-- config_src/drivers/nuopc_cap/mom_cap.F90 | 4 - .../nuopc_cap/mom_ocean_model_nuopc.F90 | 62 ++++++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 14 +-- src/core/MOM.F90 | 48 +++------- src/core/MOM_variables.F90 | 7 ++ .../vertical/MOM_diabatic_driver.F90 | 93 +++++++------------ .../vertical/MOM_energetic_PBL.F90 | 79 ++++++++-------- 9 files changed, 158 insertions(+), 179 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 97fb869ad4..6292c32469 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -50,7 +50,7 @@ module ocean_model_mod use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -186,6 +186,7 @@ module ocean_model_mod !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -576,12 +577,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -603,16 +604,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -629,7 +630,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. Time1 = Time1 - real_to_time(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 3bd0e1e28d..4a4f6eee05 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -47,7 +47,7 @@ module MOM_ocean_model_mct use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -187,6 +187,7 @@ module MOM_ocean_model_mct !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -586,12 +587,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -615,16 +616,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -641,7 +642,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 8778df067a..3de56c0511 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,9 +97,7 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -#ifdef UFS use get_stochy_pattern_mod, only: write_stoch_restart_ocn -#endif !$use omp_lib , only : omp_set_num_threads @@ -1755,7 +1753,6 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname) ! write stochastic physics restart file if active -#ifdef UFS if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then write(restartname,'(A)')"ocn_stoch.res.nc" else @@ -1764,7 +1761,6 @@ subroutine ModelAdvance(gcomp, rc) endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) -#endif endif if (is_root_pe()) then diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 448f23140e..290e6b30df 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -43,7 +43,7 @@ module MOM_ocean_model_nuopc use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, stochastic_pattern 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 @@ -62,8 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use get_stochy_pattern_mod, only : write_stoch_restart_ocn -use iso_fortran_env, only : int64 +use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs +use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -194,6 +194,7 @@ module MOM_ocean_model_nuopc !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. + type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -255,9 +256,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot !< If true, allocate melt_potential array - logical :: use_CFC !< If true, allocated arrays for surface CFCs. - + logical :: use_melt_pot!< If true, allocate melt_potential array +! stochastic physics + integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs ! number of processors to pass to stochastic physics + integer :: iret ! return code from stochastic physics + integer :: me ! my pe + integer :: master ! root pe ! This include declares and sets the variable "version". #include "version_variable.h" @@ -429,19 +435,21 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) -! get number of processors and PE list for stocasthci physics initialization - call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & - "If true, then stochastically perturb the thermodynamic "//& - "tendencies of T,S, and h. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) - call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & - "If true, then stochastically perturb the kinetic energy "//& - "production and dissipation terms. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + me=PE_here() + master=root_PE() + + call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& + OS%stochastics%pert_epbl,OS%stochastics%do_sppt,master,mom_comm,iret) + print*,'after init_stochastic_physics_ocn',OS%stochastics%pert_epbl,OS%stochastics%do_sppt + if (OS%stochastics%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%stochastics%pert_epbl) then + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -613,17 +621,23 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time +! update stochastic physics patterns before running next time-step + print*,'before call to stoch',OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl + if (OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl ) then + call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) + endif + if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -646,16 +660,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -672,7 +686,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index c35caa9d38..0db4033c8d 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -64,7 +64,7 @@ program MOM_main 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_variables, only : surface, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves @@ -93,6 +93,8 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes + type(stochastic_pattern) :: stochastics !< A structure containing pointers to + ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state @@ -493,7 +495,7 @@ program MOM_main if (offline_tracer_mode) then call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, stochastics, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -506,16 +508,16 @@ program MOM_main if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) @@ -524,7 +526,7 @@ program MOM_main ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & Time2 = Time2 - real_to_time(dtdia - dt_dyn) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) n_last_thermo = n diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bab2cf5a4a..f26d37b3c0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -30,7 +30,6 @@ module MOM 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 use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners -use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -134,7 +133,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state +use MOM_variables, only : rotate_surface_state,stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -156,9 +155,6 @@ 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 -#ifdef UFS -use stochastic_physics, only : init_stochastic_physics_ocn -#endif implicit none ; private @@ -456,13 +452,14 @@ module MOM !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. -subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & +subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & end_cycle, cycle_length, reset_therm) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state + type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM @@ -771,8 +768,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - end_time_thermo, .true., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & + dtdia, end_time_thermo, .true., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -872,8 +869,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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, & - Time_local, .false., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & + dtdia, Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1305,8 +1302,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & - Time_end_thermo, update_BBL, Waves) +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & + dtdia, Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1319,6 +1316,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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 + type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. @@ -1394,8 +1392,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) + call diabatic(u, v, h, tv, CS%Hml, fluxes, stochastics, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1807,19 +1805,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic ! time step needs to be updated before it is used. logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. - logical :: do_epbl,do_sppt integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs ! number of processors to pass to stochastic physics - integer :: iret ! return code from stochastic physics - integer :: me ! my pe - integer :: master ! root pe real :: conv2watt, conv2salt character(len=48) :: flux_units, S_flux_units @@ -2505,18 +2496,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call copy_dyngrid_to_MOM_grid(dG, G, US) call destroy_dyn_horgrid(dG) - do_epbl=.false. - do_sppt=.false. -#ifdef UFS - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - me=PE_here() - master=root_PE() - - call init_stochastic_physics_ocn(CS%dt_therm,G%geoLonT,G%geoLatT,G%ied-G%isd+1,G%jed-G%jsd+1,nz,do_epbl,do_sppt,master,mom_comm,iret) -#endif - ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) @@ -2968,9 +2947,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! call fix_restart_scaling(GV) ! call fix_restart_unit_scaling(US) - CS%diabatic_CSp%do_epbl=do_epbl - CS%diabatic_CSp%do_sppt=do_sppt - call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a9bf6c3dcf..4020721075 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -276,6 +276,13 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. +type, public :: stochastic_pattern + logical :: do_sppt = .false. + logical :: pert_epbl = .false. + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation + real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation +end type stochastic_pattern type, public :: BT_cont_type real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport !! drawing from locations far to the east [H L ~> m2 or kg m-1]. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 856dd30f4e..3894c7bffb 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -65,13 +65,10 @@ module MOM_diabatic_driver use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs -use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d +use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS -#ifdef UFS -use stochastic_physics, only : run_stochastic_physics_ocn -#endif implicit none ; private @@ -218,8 +215,6 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics - logical,public :: do_epbl = .false. !< If true pertrub u_start in ePBL calculation - logical,public :: do_sppt = .false. !< If true perturb all physics tendenceies in MOM_diabatic_driver real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil @@ -270,21 +265,21 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, stoch_CS, OBC, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields +subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, OBC, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, - !! BBL properties and related fields - type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + type(stochastic_pattern), intent(in) :: stochastics !< random patterns + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -305,36 +300,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)) :: sppt_wts - real, dimension(SZI_(G),SZJ_(G),2) :: t_rp -#ifdef UFS real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT -#endif if (G%ke == 1) return -#ifdef UFS ! save copy of the date for SPPT - if (CS%do_sppt) then - h_in=h - t_in=tv%T - s_in=tv%S - endif - call run_stochastic_physics_ocn(t_rp,sppt_wts) - if (CS%id_t_rp1 > 0) then - call post_data(CS%id_t_rp1, t_rp(:,:,1), CS%diag) - endif - if (CS%id_t_rp2 > 0) then - call post_data(CS%id_t_rp2, t_rp(:,:,2), CS%diag) - endif - if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, sppt_wts, CS%diag) + if (stochastics%do_sppt) then + h_in=h + t_in=tv%T + s_in=tv%S + + if (CS%id_sppt_wts > 0) then + call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) + endif endif -#endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -420,10 +403,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & @@ -490,14 +473,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) -#ifdef UFS - if (CS%do_sppt) then + if (stochastics%do_sppt) then do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*stochastics%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stochastics%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stochastics%sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) @@ -514,7 +496,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo endif -#endif end subroutine diabatic @@ -523,7 +504,7 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -533,10 +514,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] - type(forcing), intent(inout) :: fluxes !< points to forcing fields + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + type(stochastic_pattern), intent(in) :: stochastics !< points to forcing fields !! unused fields have NULL ptrs - real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived @@ -846,7 +827,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -1109,7 +1090,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1122,7 +1103,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: t_rp !< random pattern + type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived @@ -1383,7 +1364,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, t_rp, visc, ADp, CDp, dt, Time endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, t_rp, CS%do_epbl, dt, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -3150,12 +3131,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & - 'random pattern1 for stochastics', 'None') - CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & - 'random pattern2 for stochastics', 'None') CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & - 'random pattern for sppt', 'None') + 'random pattern for sppt', 'None') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1cf089d5ed..a0b9ee0b51 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -14,7 +14,7 @@ module MOM_energetic_PBL use MOM_grid, only : ocean_grid_type use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : thermo_var_ptrs, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -165,7 +165,6 @@ module MOM_energetic_PBL !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in !! upward or downward passes. - logical :: do_epbl type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the !! timing of diagnostic output. @@ -198,6 +197,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 + integer :: id_t_rp1=-1,id_t_rp2=-1 !>@} end type energetic_PBL_CS @@ -245,7 +245,7 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & dT_expected, dS_expected, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -276,15 +276,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. + type(stochastic_pattern), intent(in) :: stochastics !< A structure containing array to any unsued fields + !! are not allocated real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces !! [Z2 s-1 ~> m2 s-1]. type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous !! call to mixedlayer_init. - real, dimension(SZI_(G),SZJ_(G),2), & - intent(in) :: t_rp !< random pattern to perturb wind - logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -429,9 +428,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, t_rp(i,j,1),t_rp(i,j,2), stoch_epbl, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, stochastics, & + B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & + GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -470,26 +469,30 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, t_rp, stoch_epbl, dt, Kd_ enddo ! j-loop - if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) - if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) - if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) - if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) - if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) - if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) - if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) - if (CS%id_TKE_mech_decay > 0) & - call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) - if (CS%id_TKE_conv_decay > 0) & - call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) - if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) - if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) - if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) - if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - if (stoch_CS%pert_epbl) then - if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) - if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) + if (write_diags) then + if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) + if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) + if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) + if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) + if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) + ! only write random patterns if running with stochastic physics, otherwise the + ! array is unallocated and will give an error + if (stochastics%pert_epbl) then + if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) + if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + endif endif end subroutine energetic_PBL @@ -497,9 +500,9 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & +subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - t_rp1,t_rp2, stoch_epbl, dt_diag, Waves, G, i, j) + dt_diag, Waves, G, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -518,6 +521,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. + type(stochastic_pattern), intent(in) :: stochastics !< stochastic patterns and logic controls real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. @@ -536,9 +540,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - real, intent(in) :: t_rp1 !< random value to perturb TKE production - real, intent(in) :: t_rp2 !< random value to perturb TKE dissipation - logical, intent(in) :: stoch_epbl !< flag to pertrub production and dissipation of TKE real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less !! than dt if there are two calls to mixedlayer [T ~> s]. type(wave_parameters_CS), & @@ -836,7 +837,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (stoch_epbl) mech_TKE=mech_TKE*t_rp1 + if (stochastics%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -919,8 +920,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (stoch_epbl) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1+(exp_kh-1) * t_rp2) + if (stochastics%pert_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh endif @@ -2326,6 +2327,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') + CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + 'random pattern1 for stochastics', 'None') + CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + 'random pattern2 for stochastics', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From f874d11133a23bc4f5018589c0ad6c1193a6cd1b Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 29 Jan 2021 20:49:07 +0000 Subject: [PATCH 098/155] clean up MOM_domains --- src/framework/MOM_domains.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index b647c56534..60805b5f4a 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,6 +3,8 @@ 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, Get_PElist 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 From 045d5c2db9150106f55e6f52472cf998bbd8488e Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 2 Feb 2021 00:05:24 +0000 Subject: [PATCH 099/155] make stochastics optional --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 17 ++- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 15 ++- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 80 ++++++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 13 +-- src/core/MOM.F90 | 25 ++-- src/core/MOM_variables.F90 | 2 - .../vertical/MOM_diabatic_driver.F90 | 110 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 56 ++++++--- 8 files changed, 181 insertions(+), 137 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 6292c32469..e0c512250b 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -50,7 +50,7 @@ module ocean_model_mod use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -186,7 +186,6 @@ module ocean_model_mod !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -562,7 +561,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. @@ -577,12 +576,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -604,16 +603,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -630,7 +629,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. Time1 = Time1 - real_to_time(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 4a4f6eee05..3bd0e1e28d 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -47,7 +47,7 @@ module MOM_ocean_model_mct use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -187,7 +187,6 @@ module MOM_ocean_model_mct !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -587,12 +586,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -616,16 +615,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -642,7 +641,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 290e6b30df..3ac6ef542d 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -177,10 +177,8 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: do_sppt !< If true, stochastically perturb the diabatic and - !! write restarts - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and - !! genration termsand write restarts + logical :: do_sppt !< If true, allocate array for SPPT + logical :: pert_epbl !< If true, allocate arrays for energetic PBL perturbations real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -435,20 +433,38 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - me=PE_here() - master=root_PE() - - call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& - OS%stochastics%pert_epbl,OS%stochastics%do_sppt,master,mom_comm,iret) - print*,'after init_stochastic_physics_ocn',OS%stochastics%pert_epbl,OS%stochastics%do_sppt +! get number of processors and PE list for stocasthci physics initialization + call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + if (OS%do_sppt .OR. OS%pert_epbl) then + num_procs=num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + me=PE_here() + master=root_PE() + + call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& + OS%pert_epbl,OS%do_sppt,master,mom_comm,iret) + if (iret/=0) then + write(6,*) 'call to init_stochastic_physics_ocn failed' + call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & + "not activated in stochastic_physics namelist ") + return + endif - if (OS%stochastics%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - if (OS%stochastics%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%pert_epbl) then + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + endif endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -622,8 +638,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time ! update stochastic physics patterns before running next time-step - print*,'before call to stoch',OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl - if (OS%stochastics%do_sppt .OR. OS%stochastics%pert_epbl ) then + if (OS%do_sppt .OR. OS%pert_epbl ) then call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) endif @@ -631,13 +646,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & - reset_therm=Ocn_fluxes_used) + reset_therm=Ocn_fluxes_used, stochastics=OS%stochastics) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves, & + stochastics=OS%stochastics) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -660,18 +676,21 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & + stochastics=OS%stochastics) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & + stochastics=OS%stochastics) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & + stochastics=OS%stochastics) step_thermo = .false. if (thermo_does_span_coupling) then @@ -686,9 +705,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, OS%stochastics, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & + stochastics=OS%stochastics) endif endif diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 0db4033c8d..8ed8a8559f 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -64,7 +64,7 @@ program MOM_main 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, stochastic_pattern + 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 : Update_Surface_Waves @@ -93,7 +93,6 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes - type(stochastic_pattern) :: stochastics !< A structure containing pointers to ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state @@ -495,7 +494,7 @@ program MOM_main if (offline_tracer_mode) then call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, stochastics, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -508,16 +507,16 @@ program MOM_main if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) @@ -526,7 +525,7 @@ program MOM_main ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & Time2 = Time2 - real_to_time(dtdia - dt_dyn) - call step_MOM(forces, fluxes, sfc_state, stochastics, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) n_last_thermo = n diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f26d37b3c0..94b01b2067 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -452,14 +452,13 @@ module MOM !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. -subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, time_int_in, CS, & +subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & - end_cycle, cycle_length, reset_therm) + end_cycle, cycle_length, reset_therm, stochastics) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state - type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM @@ -480,6 +479,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patternss for stochastics ! local variables type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing @@ -768,8 +768,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, stochastics, & - dtdia, end_time_thermo, .true., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + end_time_thermo, .true., Waves=Waves, & + stochastics=stochastics) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -869,8 +870,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, stochastics, Time_start, ti 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, stochastics, & - dtdia, Time_local, .false., Waves=Waves) + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + Time_local, .false., Waves=Waves, & + stochastics=stochastics) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1302,8 +1304,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & - dtdia, Time_end_thermo, update_BBL, Waves) +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & + Time_end_thermo, update_BBL, Waves, stochastics) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1392,8 +1394,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, stochastics, & call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, stochastics, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves, & + stochastics=stochastics) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 4020721075..4d5c83f3bd 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -277,8 +277,6 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. type, public :: stochastic_pattern - logical :: do_sppt = .false. - logical :: pert_epbl = .false. real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 3894c7bffb..3f7d53a221 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -142,12 +142,12 @@ module MOM_diabatic_driver integer :: NKBL !< The number of buffer layers (if bulk_mixed_layer) logical :: massless_match_targets !< If true (the default), keep the T & S !! consistent with the target values. - logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless layers at the - !! bottom into the interior as though a diffusivity of - !! Kd_min_tr (see below) were operating. - logical :: mix_boundary_tracer_ALE !< If true, in ALE mode mix the passive tracers in massless - !! layers at the bottom into the interior as though a - !! diffusivity of Kd_min_tr (see below) were operating. + logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless + !! layers at the bottom into the interior as though + !! a diffusivity of Kd_min_tr (see below) were + !! operating. + logical :: do_sppt !< If true, stochastically perturb the diabatic + !! tendencies with a number between 0 and 2 real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at @@ -183,7 +183,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1=-1,id_t_rp2=-1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1 = -1, id_t_rp2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -265,8 +265,8 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES) +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, OBC, WAVES, stochastics) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -277,19 +277,18 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -300,16 +299,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in !< thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickenss before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for tendencey needed for SPPT + real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT if (G%ke == 1) return ! save copy of the date for SPPT - if (stochastics%do_sppt) then + if (CS%do_sppt) then h_in=h t_in=tv%T s_in=tv%S @@ -403,11 +402,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves,stochastics=stochastics) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves, stochastics=stochastics) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -473,7 +472,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, T if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stochastics%do_sppt) then + if (CS%do_sppt) then do k=1,nz do j=js,je do i=is,ie @@ -504,8 +503,8 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES) +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES, stochastics) 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 @@ -516,18 +515,17 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields - type(stochastic_pattern), intent(in) :: stochastics !< points to forcing fields - !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and + !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -827,8 +825,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + waves=waves, stochastics=stochastics) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -1090,8 +1089,8 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves, stochastics) 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 @@ -1103,17 +1102,17 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, d real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(stochastic_pattern), intent(in) :: stochastics !< random patterns type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and + !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1364,8 +1363,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, stochastics, visc, ADp, CDp, d endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, stochastics, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + waves=waves, stochastics=stochastics) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -3087,9 +3087,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "mass loss is passed down through the column.", & units="nondim", default=0.8) - if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & - call MOM_error(FATAL, "diabatic_driver_init: "//& - "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") + call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) ! Register all available diagnostics for this module. thickness_units = get_thickness_units(GV) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index a0b9ee0b51..4ef7239791 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -58,6 +58,7 @@ module MOM_energetic_PBL !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. real :: MixLenExponent !< Exponent in the mixing length shape-function. @@ -245,9 +246,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, G, GV, US, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves ) + dT_expected, dS_expected, Waves, stochastics ) 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 @@ -276,8 +277,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. - type(stochastic_pattern), intent(in) :: stochastics !< A structure containing array to any unsued fields - !! are not allocated real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces @@ -286,8 +285,26 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, !! call to mixedlayer_init. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. - type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less + !! than dt if there are two calls to mixedlayer [T ~> s]. + logical, optional, intent(in) :: last_call !< If true, this is the last call to + !! mixedlayer in the current time step, so + !! diagnostics will be written. The default + !! is .true. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dT_expected !< The values of temperature change that + !! should be expected when the returned + !! diffusivities are applied [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dS_expected !< The values of salinity change that + !! should be expected when the returned + !! diffusivities are applied [ppt]. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Wave CS + type(stochastic_pattern), optional, & + intent(in) :: stochastics !< A structure containing array to stochastic + !! patterns. Any unsued fields + !! are not allocated ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -428,9 +445,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, stochastics, & + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, & B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & - GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + stochastics=stochastics,i=i, j=j) ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -489,7 +507,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, stochastics, dt, Kd_int, if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error - if (stochastics%pert_epbl) then + if (CS%pert_epbl) then if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) endif @@ -500,9 +518,9 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics, B_flux, absf, & +subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, i, j) + dt_diag, Waves, G, stochastics, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -521,7 +539,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. - type(stochastic_pattern), intent(in) :: stochastics !< stochastic patterns and logic controls real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. @@ -546,6 +563,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics optional, pointer :: Waves !< Wave CS for Langmuir turbulence type(ocean_grid_type), & optional, intent(inout) :: G !< The ocean's grid structure. + type(stochastic_pattern), & + optional, intent(in) :: stochastics !< stochastic patterns and logic controls integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) @@ -837,7 +856,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (stochastics%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -920,7 +939,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, stochastics if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (stochastics%pert_epbl) then ! perturb the TKE destruction + if (CS%pert_epbl) then ! perturb the TKE destruction mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh @@ -2153,6 +2172,11 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "This is only used if USE_MLD_ITERATION is True.", & units="nondim", default=2.0) + call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) !/ Turbulent velocity scale in mixing coefficient call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & "Selects the method for translating TKE into turbulent velocities. "//& @@ -2328,9 +2352,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & - 'random pattern1 for stochastics', 'None') + 'random pattern for KE generation', 'None') CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & - 'random pattern2 for stochastics', 'None') + 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From 121ce71b30b219a7396e801d33d9c31cb0cc5838 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 2 Feb 2021 00:13:24 +0000 Subject: [PATCH 100/155] correct coupled_driver/ocean_model_MOM.F90 and other cleanup --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 2 +- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index e0c512250b..97fb869ad4 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -561,7 +561,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. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 3f7d53a221..d2e633d390 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -299,7 +299,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickenss before thermodynamics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickness before thermodynamics real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT @@ -403,7 +403,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves,stochastics=stochastics) + G, GV, US, CS, Waves, stochastics=stochastics) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves, stochastics=stochastics) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 4ef7239791..7ad3aea276 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -445,9 +445,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, & - B_flux, absf, u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, & - GV, US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & stochastics=stochastics,i=i, j=j) ! Copy the diffusivities to a 2-d array. From 65e0e71bb316c234544ce0f7f277102e22af61e2 Mon Sep 17 00:00:00 2001 From: Philip Pegion Date: Tue, 2 Feb 2021 09:45:46 -0600 Subject: [PATCH 101/155] clean up of code for MOM6 coding standards --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 8 +++--- src/core/MOM.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 27 ++++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 10 +++---- 4 files changed, 24 insertions(+), 23 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 3ac6ef542d..c20b0a08ef 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -460,10 +460,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i return endif - if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) if (OS%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) endif endif call close_param_file(param_file) @@ -639,7 +639,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! update stochastic physics patterns before running next time-step if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%stochastics%sppt_wts,OS%stochastics%t_rp1,OS%stochastics%t_rp2) + call run_stochastic_physics_ocn(OS%stochastics%sppt_wts, OS%stochastics%t_rp1, OS%stochastics%t_rp2) endif if (OS%offline_tracer_mode) then diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 94b01b2067..ddc938639f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -133,7 +133,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state,stochastic_pattern +use MOM_variables, only : rotate_surface_state, stochastic_pattern use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d2e633d390..43c8c9b348 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -309,9 +309,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! save copy of the date for SPPT if (CS%do_sppt) then - h_in=h - t_in=tv%T - s_in=tv%S + h_in(:,:,:)=h(:,:,:) + t_in(:,:,:)=tv%T(:,:,:) + s_in(:,:,:)=tv%S(:,:,:) if (CS%id_sppt_wts > 0) then call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) @@ -473,23 +473,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) if (CS%do_sppt) then + ! perturb diabatic tendecies do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stochastics%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stochastics%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stochastics%sppt_wts(i,j) - h_pert=h_tend+h_in(i,j,k) - t_pert=t_tend+t_in(i,j,k) - s_pert=s_tend+s_in(i,j,k) + h_tend = (h(i,j,k) - h_in(i,j,k)) * stochastics%sppt_wts(i,j) + t_tend = (tv%T(i,j,k) - t_in(i,j,k)) * stochastics%sppt_wts(i,j) + s_tend = (tv%S(i,j,k) - s_in(i,j,k)) * stochastics%sppt_wts(i,j) + h_pert = h_tend + h_in(i,j,k) + t_pert = t_tend + t_in(i,j,k) + s_pert = s_tend + s_in(i,j,k) if (h_pert > GV%Angstrom_H) then - h(i,j,k)=h_pert + h(i,j,k) = h_pert else - h(i,j,k)=GV%Angstrom_H + h(i,j,k) = GV%Angstrom_H endif - tv%T(i,j,k)=t_pert + tv%T(i,j,k) = t_pert if (s_pert > 0.0) then - tv%S(i,j,k)=s_pert + tv%S(i,j,k) = s_pert endif enddo enddo diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7ad3aea276..1655cdab4c 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -198,7 +198,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_t_rp1=-1,id_t_rp2=-1 + integer :: id_t_rp1=-1, id_t_rp2=-1 !>@} end type energetic_PBL_CS @@ -508,8 +508,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error if (CS%pert_epbl) then - if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) - if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) + if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) endif endif end subroutine energetic_PBL @@ -856,7 +856,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE=mech_TKE*stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE = mech_TKE * stochastics%t_rp1(i,j) if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -939,7 +939,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE destruction + if (CS%pert_epbl) then ! perturb the TKE dissipation mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) else mech_TKE = mech_TKE * exp_kh From 80fdfb4e87c0e78227ac5c2f5c93f8bac4d7dd3a Mon Sep 17 00:00:00 2001 From: pjpegion Date: Thu, 4 Feb 2021 16:59:22 +0000 Subject: [PATCH 102/155] remove stochastics container --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 37 ++++++------- src/core/MOM.F90 | 15 ++---- src/core/MOM_variables.F90 | 5 -- src/framework/MOM_domains.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 52 +++++++++---------- .../vertical/MOM_energetic_PBL.F90 | 45 ++++++++-------- 6 files changed, 69 insertions(+), 87 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index c20b0a08ef..ea64808f26 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -43,7 +43,7 @@ module MOM_ocean_model_nuopc use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, stochastic_pattern +use MOM_variables, only : surface 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 @@ -51,7 +51,7 @@ module MOM_ocean_model_nuopc 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 : domain2d, mpp_get_layout, mpp_get_global_domain,mpp_get_pelist use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use fms_mod, only : stdout use mpp_mod, only : mpp_chksum @@ -62,7 +62,7 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,PE_here,Get_PElist,num_PEs +use MOM_domains, only : root_PE,PE_here,num_PEs use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -192,7 +192,6 @@ module MOM_ocean_model_nuopc !! timesteps are taken per thermodynamic step. type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. - type(stochastic_pattern) :: stochastics !< A structure containing pointers to type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics !! and related information. @@ -256,7 +255,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot!< If true, allocate melt_potential array ! stochastic physics - integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean integer :: mom_comm ! list of pes for this instance of the ocean integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics @@ -446,8 +444,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i default=.false.) if (OS%do_sppt .OR. OS%pert_epbl) then num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) + call mpp_get_pelist(Ocean_sfc%domain, mom_comm) me=PE_here() master=root_PE() @@ -460,10 +457,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i return endif - if (OS%do_sppt) allocate(OS%stochastics%sppt_wts(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + if (OS%do_sppt) allocate(OS%fluxes%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) if (OS%pert_epbl) then - allocate(OS%stochastics%t_rp1(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) - allocate(OS%stochastics%t_rp2(OS%grid%isd:OS%grid%ied, OS%grid%jsd:OS%grid%jed)) + allocate(OS%fluxes%epbl1_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) + allocate(OS%fluxes%epbl2_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) endif endif call close_param_file(param_file) @@ -639,7 +636,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! update stochastic physics patterns before running next time-step if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%stochastics%sppt_wts, OS%stochastics%t_rp1, OS%stochastics%t_rp2) + call run_stochastic_physics_ocn(OS%fluxes%sppt_wts,OS%fluxes%epbl1_wts,OS%fluxes%epbl2_wts) endif if (OS%offline_tracer_mode) then @@ -648,12 +645,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! The call sequence is being orchestrated from outside of update_ocean_model. call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & - reset_therm=Ocn_fluxes_used, stochastics=OS%stochastics) + reset_therm=Ocn_fluxes_used) !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves, & - stochastics=OS%stochastics) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -678,19 +674,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & dtdia = dt_dyn*min(nts,n_max-(n-1)) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -707,8 +700,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling, & - stochastics=OS%stochastics) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + endif endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ddc938639f..477d185e96 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -454,7 +454,7 @@ module MOM !! occur inside of diabatic. subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & - end_cycle, cycle_length, reset_therm, stochastics) + end_cycle, cycle_length, reset_therm) type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields @@ -479,7 +479,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patternss for stochastics ! local variables type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing @@ -769,8 +768,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - end_time_thermo, .true., Waves=Waves, & - stochastics=stochastics) + end_time_thermo, .true., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. @@ -871,8 +869,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & - Time_local, .false., Waves=Waves, & - stochastics=stochastics) + Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -1305,7 +1302,7 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & - Time_end_thermo, update_BBL, Waves, stochastics) + Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1318,7 +1315,6 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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 - type(stochastic_pattern), intent(in) :: stochastics !< surface ocean state real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. @@ -1395,8 +1391,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves, & - stochastics=stochastics) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 4d5c83f3bd..a9bf6c3dcf 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -276,11 +276,6 @@ module MOM_variables !> Container for information about the summed layer transports !! and how they will vary as the barotropic velocity is changed. -type, public :: stochastic_pattern - real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - real, allocatable :: t_rp1(:,:) !< Random pattern for K.E. generation - real, allocatable :: t_rp2(:,:) !< Random pattern for K.E. dissipation -end type stochastic_pattern type, public :: BT_cont_type real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport !! drawing from locations far to the east [H L ~> m2 or kg m-1]. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 60805b5f4a..cfc3ee106a 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -17,7 +17,7 @@ module MOM_domains 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 :: pass_var, pass_vector, PE_here, root_PE, num_PEs, Get_PElist +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 :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 43c8c9b348..9ae391815b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -65,7 +65,7 @@ module MOM_diabatic_driver use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs -use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d, stochastic_pattern +use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS @@ -183,7 +183,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1, id_t_rp1 = -1, id_t_rp2 = -1 + integer :: id_subMLN2 = -1, id_sppt_wts = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -266,7 +266,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES, stochastics) + G, GV, US, CS, OBC, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -288,7 +288,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(diabatic_CS), pointer :: CS !< module control structure type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -299,9 +298,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_in ! thickness before thermodynamics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: t_in ! temperature before thermodynamics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: s_in ! salinity before thermodynamics + real, allocatable(:,:,:) :: h_in ! thickness before thermodynamics + real, allocatable(:,:,:) :: t_in ! temperature before thermodynamics + real, allocatable(:,:,:) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT @@ -309,12 +308,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! save copy of the date for SPPT if (CS%do_sppt) then - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) + allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) + h_in(:,:) = h(:,:) + t_in(:,:) = tv%T(:,:) + s_in(:,:) = tv%S(:,:) if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, stochastics%sppt_wts, CS%diag) + call post_data(CS%id_sppt_wts, fluxes%sppt_wts, CS%diag) endif endif @@ -403,10 +405,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics=stochastics) + G, GV, US, CS, Waves) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics=stochastics) + G, GV, US, CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -477,12 +479,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k) - h_in(i,j,k)) * stochastics%sppt_wts(i,j) - t_tend = (tv%T(i,j,k) - t_in(i,j,k)) * stochastics%sppt_wts(i,j) - s_tend = (tv%S(i,j,k) - s_in(i,j,k)) * stochastics%sppt_wts(i,j) - h_pert = h_tend + h_in(i,j,k) - t_pert = t_tend + t_in(i,j,k) - s_pert = s_tend + s_in(i,j,k) + h_tend = (h(i,j,k)-h_in(i,j,k))*fluxes%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*fluxes%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*fluxes%sppt_wts(i,j) + h_pert=h_tend+h_in(i,j,k) + t_pert=t_tend+t_in(i,j,k) + s_pert=s_tend+s_in(i,j,k) if (h_pert > GV%Angstrom_H) then h(i,j,k) = h_pert else @@ -505,7 +507,7 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES, stochastics) + G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -525,8 +527,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and - !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -828,7 +828,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves, stochastics=stochastics) + waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -1091,7 +1091,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves, stochastics) + G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1112,8 +1112,6 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - type(stochastic_pattern), optional, intent(in) :: stochastics !< random patterns for SPPT and - !! energetic PBL perturbations ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1366,7 +1364,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves, stochastics=stochastics) + waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1655cdab4c..8a708e4861 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -14,7 +14,7 @@ module MOM_energetic_PBL use MOM_grid, only : ocean_grid_type use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs, stochastic_pattern +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -198,7 +198,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_t_rp1=-1, id_t_rp2=-1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 !>@} end type energetic_PBL_CS @@ -248,7 +248,7 @@ module MOM_energetic_PBL !! is no stability limit on the time step. subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves, stochastics ) + dT_expected, dS_expected, Waves) 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 @@ -301,10 +301,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS !! diffusivities are applied [ppt]. type(wave_parameters_CS), & optional, pointer :: Waves !< Wave CS - type(stochastic_pattern), optional, & - intent(in) :: stochastics !< A structure containing array to stochastic - !! patterns. Any unsued fields - !! are not allocated ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -444,11 +440,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - stochastics=stochastics,i=i, j=j) + if (CS%pert_epbl) then ! stochastics are active + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & + epbl1_wt=epbl1_wts(i,j),epbl2_wt=epbl2_wts(i,j),i=i, j=j) + else + call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + endif ! Copy the diffusivities to a 2-d array. do K=1,nz+1 @@ -508,8 +509,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error if (CS%pert_epbl) then - if (CS%id_t_rp1 > 0) call post_data(CS%id_t_rp1, stochastics%t_rp1, CS%diag) - if (CS%id_t_rp2 > 0) call post_data(CS%id_t_rp2, stochastics%t_rp2, CS%diag) + if (CS%id_epbl1_wts > 0) call post_data(CS%id_epbl1_wts, stochastics%epbl1_wts, CS%diag) + if (CS%id_epbl2_wts > 0) call post_data(CS%id_epbl2_wts, stochastics%epbl2_wts, CS%diag) endif endif end subroutine energetic_PBL @@ -520,7 +521,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, stochastics, i, j) + dt_diag, Waves, G, epbl1_wt, epbl2_wt, i, j) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -563,8 +564,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs optional, pointer :: Waves !< Wave CS for Langmuir turbulence type(ocean_grid_type), & optional, intent(inout) :: G !< The ocean's grid structure. - type(stochastic_pattern), & - optional, intent(in) :: stochastics !< stochastic patterns and logic controls + real, optional, intent(in) :: epbl1_wt ! random number to perturb KE generation + real, optional, intent(in) :: epbl2_wt ! random number to perturb KE dissipation integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) @@ -856,7 +857,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE = mech_TKE * stochastics%t_rp1(i,j) + if (CS%pert_epbl) mech_TKE=mech_TKE*epbl1_wt if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -939,8 +940,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE dissipation - mech_TKE = mech_TKE * (1+(exp_kh-1) * stochastics%t_rp2(i,j)) + if (CS%pert_epbl) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) else mech_TKE = mech_TKE * exp_kh endif @@ -2351,9 +2352,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') - CS%id_t_rp1 = register_diag_field('ocean_model', 'random_pattern1', diag%axesT1, Time, & + CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', diag%axesT1, Time, & 'random pattern for KE generation', 'None') - CS%id_t_rp2 = register_diag_field('ocean_model', 'random_pattern2', diag%axesT1, Time, & + CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', diag%axesT1, Time, & 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & From b12c09cbba9df88ee6494530f7a72a78810a25e0 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:18:31 +0000 Subject: [PATCH 103/155] revert MOM_domains.F90 --- src/framework/MOM_domains.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index cfc3ee106a..aedf9d5d0d 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,9 +3,8 @@ 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, Get_PElist +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 From 077413af9f4196b07bcc929d026fb03688269fe5 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:50:56 +0000 Subject: [PATCH 104/155] clean up of mom_ocean_model_nuopc.F90 --- config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index ea64808f26..9e43638751 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -51,7 +51,7 @@ module MOM_ocean_model_nuopc 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,mpp_get_pelist +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 mpp_mod, only : mpp_chksum @@ -444,7 +444,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i default=.false.) if (OS%do_sppt .OR. OS%pert_epbl) then num_procs=num_PEs() - call mpp_get_pelist(Ocean_sfc%domain, mom_comm) + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) me=PE_here() master=root_PE() @@ -701,7 +702,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) - endif endif From ebe9d1f6f8cab97fd8e0cdd686c6d9d0e39702bb Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 5 Feb 2021 20:54:05 +0000 Subject: [PATCH 105/155] remove PE_here from mom_ocean_model_nuopc.F90 --- config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 9e43638751..1ef5b07c06 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -62,7 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,PE_here,num_PEs +use MOM_domains, only : root_PE,num_PEs +use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -446,7 +447,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - me=PE_here() master=root_PE() call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& From 0932b9ec13643949bd217e4c034166ef06e806fd Mon Sep 17 00:00:00 2001 From: pjpegion Date: Fri, 26 Feb 2021 17:43:50 +0000 Subject: [PATCH 106/155] remove debug statements --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 8a708e4861..7cf8d48ae0 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -945,6 +945,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = mech_TKE * exp_kh endif + !if ( i .eq. 10 .and. j .eq. 10 .and. k .eq. nz) print*,'mech TKE', mech_TKE ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 199126eb7c86350b8bcc1884ea148ceba0133188 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 15:09:50 +0000 Subject: [PATCH 107/155] stochastic physics re-write --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 38 +---- src/core/MOM.F90 | 25 +-- src/core/MOM_forcing_type.F90 | 2 - .../stochastic/MOM_stochastics.F90 | 50 +++--- .../stochastic/MOM_stochastics_stub.F90 | 64 ++++++++ .../vertical/MOM_diabatic_driver.F90 | 155 +++++++++--------- .../vertical/MOM_energetic_PBL.F90 | 34 ++-- 7 files changed, 204 insertions(+), 164 deletions(-) create mode 100644 src/parameterizations/stochastic/MOM_stochastics_stub.F90 diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1ef5b07c06..9ffe4cd794 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -64,7 +64,6 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : forcing_save_restart use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist -use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include @@ -178,8 +177,8 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: do_sppt !< If true, allocate array for SPPT - logical :: pert_epbl !< If true, allocate arrays for energetic PBL perturbations + logical,public :: do_sppt !< If true, write stochastic physics restarts + logical,public :: pert_epbl !< If true, write stochastic physics restarts real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -255,12 +254,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot!< If true, allocate melt_potential array -! stochastic physics - integer :: mom_comm ! list of pes for this instance of the ocean - integer :: num_procs ! number of processors to pass to stochastic physics - integer :: iret ! return code from stochastic physics - integer :: me ! my pe - integer :: master ! root pe ! This include declares and sets the variable "version". #include "version_variable.h" @@ -432,7 +425,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif -! get number of processors and PE list for stocasthci physics initialization + ! check to see if stochastic physics is active call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& "tendemcies of T,S, amd h. Amplitude and correlations are "//& @@ -443,27 +436,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "production and dissipation terms. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) - if (OS%do_sppt .OR. OS%pert_epbl) then - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - master=root_PE() - - call init_stochastic_physics_ocn(OS%dt_therm,OS%grid%geoLonT,OS%grid%geoLatT,OS%grid%ied-OS%grid%isd+1,OS%grid%jed-OS%grid%jsd+1,OS%grid%ke,& - OS%pert_epbl,OS%do_sppt,master,mom_comm,iret) - if (iret/=0) then - write(6,*) 'call to init_stochastic_physics_ocn failed' - call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & - "not activated in stochastic_physics namelist ") - return - endif - if (OS%do_sppt) allocate(OS%fluxes%sppt_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - if (OS%pert_epbl) then - allocate(OS%fluxes%epbl1_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - allocate(OS%fluxes%epbl2_wts(OS%grid%isd:OS%grid%ied,OS%grid%jsd:OS%grid%jed)) - endif - endif call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -635,11 +608,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time -! update stochastic physics patterns before running next time-step - if (OS%do_sppt .OR. OS%pert_epbl ) then - call run_stochastic_physics_ocn(OS%fluxes%sppt_wts,OS%fluxes%epbl1_wts,OS%fluxes%epbl2_wts) - endif - if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 477d185e96..a0594290ee 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -403,16 +403,6 @@ module MOM type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling !! ensemble model state vectors and data assimilation !! increments and priors - type(porous_barrier_ptrs) :: pbv !< porous barrier fractional cell metrics - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) & - :: por_face_areaU !< fractional open area of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) & - :: por_face_areaV !< fractional open area of V-faces [nondim] - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) & - :: por_layer_widthU !< fractional open width of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) & - :: por_layer_widthV !< fractional open width of V-faces [nondim] - type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure end type MOM_control_struct @@ -673,7 +663,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call disable_averaging(CS%diag) endif endif - ! advance the random pattern if stochastic physics is active + if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then @@ -825,6 +815,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & Time_local, Waves=Waves) @@ -1391,7 +1382,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS,OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -2500,6 +2491,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & else call set_first_direction(G, modulo(first_direction, 2)) endif + call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + call destroy_dyn_horgrid(dG_in) + + if (.not. CS%rotate_index) & + G => G_in + ! initialize stochastic physics + !call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) + ! Set a few remaining fields that are specific to the ocean grid type. + call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index bdf4823f81..4a702d4c0e 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,8 +170,6 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] - real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux - !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 21a22a222e..5bcf158f7e 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -4,10 +4,13 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. ! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, update, and writing restart of stochastic physics. This +! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. + use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type @@ -26,13 +29,11 @@ module MOM_stochastics public stochastics_init, update_stochastics -!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT - integer :: id_epbl1_wts=-1 !< Diagnostic id for epbl generation perturbation - integer :: id_epbl2_wts=-1 !< Diagnostic id for epbl dissipation perturbation + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 @@ -42,14 +43,22 @@ module MOM_stochastics type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type stochastic_CS +!> This type is used for communication with other components via the FMS coupler. +!! The element names and types can be changed only with great deliberation, hence +!! the persistnce of things like the cutsy element name "avg_kount". contains -!! This subroutine initializes the stochastics physics control structure. +!> ocean_model_init initializes the ocean model, including registering fields +!! for restarts and reading restart files if appropriate. +!! +!! This subroutine initializes both the ocean state and the ocean surface type. +!! Because of the way that indicies and domains are handled, Ocean_sfc must have +!! been used in a previous call to cean_type. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid !< horizontal grid information - type(verticalGrid_type), intent(in) :: GV !< vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS !< stochastic control structure + type(ocean_grid_type), intent(in) :: grid ! horizontal grid information + type(verticalGrid_type), intent(in) :: GV ! vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(time_type), target :: Time !< model time @@ -59,7 +68,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics integer :: me ! my pe - integer :: pe_zero ! root pe + integer :: master ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo @@ -95,13 +104,15 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - pe_zero=root_PE() - nx = grid%ied - grid%isd + 1 - ny = grid%jed - grid%jsd + 1 + master=root_PE() + nx=grid%ied-grid%isd+1 + ny=grid%jed-grid%jsd+1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) + CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then - call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") + write(6,*) 'call to init_stochastic_physics_ocn failed' + call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & + "not activated in stochastic_physics namelist ") return endif @@ -122,7 +133,6 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) write(*,'(/12x,a/)') '=== COMPLETED MOM STOCHASTIC INITIALIZATION =====' call callTree_leave("ocean_model_init(") - return end subroutine stochastics_init !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the @@ -135,9 +145,9 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + print*,'in update_stoch',minval(CS%sppt_wts),maxval(CS%sppt_wts),minval(CS%epbl1_wts),maxval(CS%epbl1_wts) - return end subroutine update_stochastics end module MOM_stochastics diff --git a/src/parameterizations/stochastic/MOM_stochastics_stub.F90 b/src/parameterizations/stochastic/MOM_stochastics_stub.F90 new file mode 100644 index 0000000000..f03f5283d3 --- /dev/null +++ b/src/parameterizations/stochastic/MOM_stochastics_stub.F90 @@ -0,0 +1,64 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. +module MOM_stochastics + +! This file is part of MOM6. See LICENSE.md for the license. + +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, termination and update of ocean model state. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. + +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +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 MOM_domains, only : root_PE,num_PEs +use MOM_coms, only : Get_PElist + +#include + +implicit none ; private + +public stochastics_init, update_stochastics + +type, public:: stochastic_CS + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 + integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + ! stochastic patterns + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + !! tendencies with a number between 0 and 2 + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) +end type stochastic_CS + +contains + +subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) + real, intent(in) :: dt !< time step [T ~> s] + type(ocean_grid_type), intent(in) :: grid ! horizontal grid information + type(verticalGrid_type), intent(in) :: GV ! vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(time_type), target :: Time !< model time + return +end subroutine stochastics_init + +subroutine update_stochastics(CS) + type(stochastic_CS), intent(inout) :: CS !< diabatic control structure + return +end subroutine update_stochastics + +end module MOM_stochastics + diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9ae391815b..319a6f2be6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -69,6 +69,7 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS +use MOM_stochastics, only : stochastic_CS implicit none ; private @@ -142,12 +143,12 @@ module MOM_diabatic_driver integer :: NKBL !< The number of buffer layers (if bulk_mixed_layer) logical :: massless_match_targets !< If true (the default), keep the T & S !! consistent with the target values. - logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless - !! layers at the bottom into the interior as though - !! a diffusivity of Kd_min_tr (see below) were - !! operating. - logical :: do_sppt !< If true, stochastically perturb the diabatic - !! tendencies with a number between 0 and 2 + logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless layers at the + !! bottom into the interior as though a diffusivity of + !! Kd_min_tr (see below) were operating. + logical :: mix_boundary_tracer_ALE !< If true, in ALE mode mix the passive tracers in massless + !! layers at the bottom into the interior as though a + !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at @@ -175,15 +176,20 @@ module MOM_diabatic_driver real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) - integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic - integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 - integer :: id_ea_t = -1, id_eb_t = -1 - integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 - integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 - integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_sppt_wts = -1 + integer :: id_cg1 = -1 ! diag handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds + integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 + integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 + ! These are handles to diagnostics related to the mixed layer properties. + integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 + + ! These are handles to diatgnostics that are only available in non-ALE layered mode. + integer :: id_wd = -1 + integer :: id_dudt_dia = -1, id_dvdt_dia = -1 + integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -266,13 +272,13 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, OBC, WAVES) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, OBC, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + 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] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -281,13 +287,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diabatic_CS), pointer :: CS !< module control structure - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -307,16 +314,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (G%ke == 1) return ! save copy of the date for SPPT - if (CS%do_sppt) then + if (stoch_CS%do_sppt) then allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:) = h(:,:) - t_in(:,:) = tv%T(:,:) - s_in(:,:) = tv%S(:,:) + h_in(:,:,:)=h(:,:,:) + t_in(:,:,:)=tv%T(:,:,:) + s_in(:,:,:)=tv%S(:,:,:) - if (CS%id_sppt_wts > 0) then - call post_data(CS%id_sppt_wts, fluxes%sppt_wts, CS%diag) + if (stoch_CS%id_sppt_wts > 0) then + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) endif endif @@ -405,10 +412,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + G, GV, US, CS, stoch_CS, Waves) elseif (CS%useALEalgorithm) then call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) + G, GV, US, CS, stoch_CS, Waves) else call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) @@ -474,14 +481,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (CS%do_sppt) then + if (stoch_CS%do_sppt) then ! perturb diabatic tendecies do k=1,nz do j=js,je do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*fluxes%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*fluxes%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*fluxes%sppt_wts(i,j) + h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) + t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) + s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) h_pert=h_tend+h_in(i,j,k) t_pert=t_tend+t_in(i,j,k) s_pert=s_tend+s_in(i,j,k) @@ -507,14 +514,14 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -522,11 +529,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -827,7 +835,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & waves=waves) if (associated(Hml)) then @@ -1091,14 +1099,14 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, Waves) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -1107,11 +1115,12 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [T ~> s] - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1363,7 +1372,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & + CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & waves=waves) if (associated(Hml)) then @@ -3086,11 +3095,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "mass loss is passed down through the column.", & units="nondim", default=0.8) - call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & - "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) + if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & + call MOM_error(FATAL, "diabatic_driver_init: "//& + "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") ! Register all available diagnostics for this module. thickness_units = get_thickness_units(GV) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7cf8d48ae0..36e92c2850 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -58,7 +58,6 @@ module MOM_energetic_PBL !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. real :: MixLenExponent !< Exponent in the mixing length shape-function. @@ -198,7 +197,6 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 !>@} end type energetic_PBL_CS @@ -246,9 +244,9 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, last_call, & - dT_expected, dS_expected, Waves) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, & + last_call, dT_expected, dS_expected, Waves) 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 @@ -301,6 +299,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS !! diffusivities are applied [ppt]. type(wave_parameters_CS), & optional, pointer :: Waves !< Wave CS + type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -440,11 +440,12 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) - if (CS%pert_epbl) then ! stochastics are active + if (stoch_CS%pert_epbl) then ! stochastics are active call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - epbl1_wt=epbl1_wts(i,j),epbl2_wt=epbl2_wts(i,j),i=i, j=j) + epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j), & + i=i, j=j) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & @@ -508,9 +509,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) ! only write random patterns if running with stochastic physics, otherwise the ! array is unallocated and will give an error - if (CS%pert_epbl) then - if (CS%id_epbl1_wts > 0) call post_data(CS%id_epbl1_wts, stochastics%epbl1_wts, CS%diag) - if (CS%id_epbl2_wts > 0) call post_data(CS%id_epbl2_wts, stochastics%epbl2_wts, CS%diag) + if (stoch_CS%pert_epbl) then + if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) + if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif endif end subroutine energetic_PBL @@ -857,7 +858,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically pertrub mech_TKE in the UFS - if (CS%pert_epbl) mech_TKE=mech_TKE*epbl1_wt + if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -940,7 +941,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (CS%pert_epbl) then ! perturb the TKE destruction + if (present(epbl2_wt)) then ! perturb the TKE destruction mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) else mech_TKE = mech_TKE * exp_kh @@ -2174,11 +2175,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "This is only used if USE_MLD_ITERATION is True.", & units="nondim", default=2.0) - call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & - "If true, then stochastically perturb the kinetic energy "//& - "production and dissipation terms. Amplitude and correlations are "//& - "controlled by the nam_stoch namelist in the UFS model only.", & - default=.false.) !/ Turbulent velocity scale in mixing coefficient call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & "Selects the method for translating TKE into turbulent velocities. "//& @@ -2353,10 +2349,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') - CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', diag%axesT1, Time, & - 'random pattern for KE generation', 'None') - CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', diag%axesT1, Time, & - 'random pattern for KE dissipation', 'None') if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') From 97bbdbf6f6db2043daeab1bdb748ba4cf4c93953 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 17:35:27 +0000 Subject: [PATCH 108/155] move stochastics to external directory --- .../external/OCEAN_stochastic_phyiscs}/MOM_stochastics.F90 | 0 .../external/OCEAN_stochastic_phyiscs}/MOM_stochastics_stub.F90 | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {src/parameterizations/stochastic => config_src/external/OCEAN_stochastic_phyiscs}/MOM_stochastics.F90 (100%) rename {src/parameterizations/stochastic => config_src/external/OCEAN_stochastic_phyiscs}/MOM_stochastics_stub.F90 (100%) diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 similarity index 100% rename from src/parameterizations/stochastic/MOM_stochastics.F90 rename to config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 diff --git a/src/parameterizations/stochastic/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 similarity index 100% rename from src/parameterizations/stochastic/MOM_stochastics_stub.F90 rename to config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 From 8382652d502cd7a5e1d42cab047d63aa08bae6df Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 18:14:44 +0000 Subject: [PATCH 109/155] doxygen cleanup --- .../external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 | 5 +++-- .../OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 | 7 +++++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 1 - 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 5bcf158f7e..03b33dc2b3 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -29,6 +29,7 @@ module MOM_stochastics public stochastics_init, update_stochastics +!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS logical :: do_sppt !< If true, stochastically perturb the diabatic logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms @@ -105,8 +106,8 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) master=root_PE() - nx=grid%ied-grid%isd+1 - ny=grid%jed-grid%jsd+1 + nx = grid%ied - grid%isd + 1 + ny = grid%jed - grid%jsd + 1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 index f03f5283d3..89a6d43c4f 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 @@ -28,11 +28,14 @@ module MOM_stochastics public stochastics_init, update_stochastics +!> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms + !>@{ Diagnostic IDs integer :: id_sppt_wts = -1 integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + !>@} ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 36e92c2850..9ecba8a7b8 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -301,7 +301,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS optional, pointer :: Waves !< Wave CS type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous - ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes ! have already been applied. All calculations are done implicitly, and there From 3e573eb11e605b4af21bad4dfe319fe2436b3ee4 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Mon, 26 Jul 2021 21:41:16 +0000 Subject: [PATCH 110/155] add write_stoch_restart_ocn to MOM_stochastics --- config_src/drivers/nuopc_cap/mom_cap.F90 | 18 +++++++++++------- .../MOM_stochastics.F90 | 18 +++++++++++++++--- 2 files changed, 26 insertions(+), 10 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 3de56c0511..25de32d526 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -97,8 +97,8 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -use get_stochy_pattern_mod, only: write_stoch_restart_ocn +use MOM_stochastics, only : write_mom_restart_stoch !$use omp_lib , only : omp_set_num_threads implicit none; private @@ -1752,12 +1752,16 @@ subroutine ModelAdvance(gcomp, rc) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname) - ! write stochastic physics restart file if active - if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc" - else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" + if (ocean_state%do_sppt .OR. ocean_state%pert_epbl) then + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"ocn_stoch.res.nc" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" + endif + call ESMF_LogWrite("MOM_cap: Writing stoch restart : "//trim(restartname), & + ESMF_LOGMSG_INFO) + call write_mom_restart_stoch('RESTART/'//trim(restartname)) endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) call write_stoch_restart_ocn('RESTART/'//trim(restartname)) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 03b33dc2b3..ab33a17c29 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -22,12 +22,13 @@ module MOM_stochastics use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn +use get_stochy_pattern_mod, only: write_stoch_restart_ocn #include implicit none ; private -public stochastics_init, update_stochastics +public stochastics_init, update_stochastics, write_mom_restart_stoch !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS @@ -146,10 +147,21 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) - print*,'in update_stoch',minval(CS%sppt_wts),maxval(CS%sppt_wts),minval(CS%epbl1_wts),maxval(CS%epbl1_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + return end subroutine update_stochastics +!< wrapper to write ocean stochastic restarts +subroutine write_mom_restart_stoch(filename) + character(len=*) :: filename + + call callTree_enter("write_mom_restart_stoch(), MOM_stochastics.F90") + + call write_stoch_restart_ocn(filename) + + return +end subroutine write_mom_restart_stoch + end module MOM_stochastics From 64e83b7aa1e00e989380a76b68a5aea6fa0a0e4b Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 27 Jul 2021 17:08:13 +0000 Subject: [PATCH 111/155] add logic to remove incrments from restart if outside IAU window --- src/ocean_data_assim/MOM_oda_incupd.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 5f38fa15d0..33e1c0844f 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -554,6 +554,16 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) if (CS%ncount >= CS%nstep_incupd) then if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") return + if (CS%ncount == CS%nstep_incupd) then + call register_restart_field_as_obsolete("oda_incupd_ncount", "none", CS) + call register_restart_field_as_obsolete("T_inc", "none", CS) + call register_restart_field_as_obsolete("S_inc", "none", CS) + call register_restart_field_as_obsolete("h_obs", "none", CS) + if (CS%uv_inc) then + call register_restart_field_as_obsolete("u_inc", "none", CS) + call register_restart_field_as_obsolete("v_inc", "none", CS) + endif + endif endif !ncount>CS%nstep_incupd ! update counter From 8775c6d41add72c6f71983107bc8c5be84e0fbc8 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 28 Jul 2021 17:35:21 +0000 Subject: [PATCH 112/155] revert logic wrt increments --- src/ocean_data_assim/MOM_oda_incupd.F90 | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 33e1c0844f..f087ad71c0 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -415,7 +415,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo endif enddo; enddo - + ! remap u to h_obs to get increment if (CS%uv_inc) then call pass_var(h, G%Domain) @@ -554,16 +554,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) if (CS%ncount >= CS%nstep_incupd) then if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") return - if (CS%ncount == CS%nstep_incupd) then - call register_restart_field_as_obsolete("oda_incupd_ncount", "none", CS) - call register_restart_field_as_obsolete("T_inc", "none", CS) - call register_restart_field_as_obsolete("S_inc", "none", CS) - call register_restart_field_as_obsolete("h_obs", "none", CS) - if (CS%uv_inc) then - call register_restart_field_as_obsolete("u_inc", "none", CS) - call register_restart_field_as_obsolete("v_inc", "none", CS) - endif - endif endif !ncount>CS%nstep_incupd ! update counter From 71f7354d90fa8ceb8516cc476473a4c89b67823e Mon Sep 17 00:00:00 2001 From: pjpegion Date: Wed, 28 Jul 2021 19:40:29 +0000 Subject: [PATCH 113/155] add comments --- .../MOM_stochastics.F90 | 16 +++------------- .../MOM_stochastics_stub.F90 | 17 +++++++++-------- src/core/MOM.F90 | 4 +--- .../vertical/MOM_diabatic_driver.F90 | 2 +- 4 files changed, 14 insertions(+), 25 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index ab33a17c29..427b3c754b 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -4,13 +4,10 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. ! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, termination and update of ocean model state. This +! for initialization, update, and writing restart of stochastic physics. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! -! This code is a stop-gap wrapper of the MOM6 code to enable it to be called -! in the same way as MOM4. - use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type @@ -45,17 +42,9 @@ module MOM_stochastics type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type stochastic_CS -!> This type is used for communication with other components via the FMS coupler. -!! The element names and types can be changed only with great deliberation, hence -!! the persistnce of things like the cutsy element name "avg_kount". contains -!> ocean_model_init initializes the ocean model, including registering fields -!! for restarts and reading restart files if appropriate. -!! -!! This subroutine initializes both the ocean state and the ocean surface type. -!! Because of the way that indicies and domains are handled, Ocean_sfc must have -!! been used in a previous call to cean_type. +!! This subroutine initializes the stochastics physics control structure. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] type(ocean_grid_type), intent(in) :: grid ! horizontal grid information @@ -135,6 +124,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) write(*,'(/12x,a/)') '=== COMPLETED MOM STOCHASTIC INITIALIZATION =====' call callTree_leave("ocean_model_init(") + return end subroutine stochastics_init !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 index 89a6d43c4f..349d56c0c7 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 @@ -3,13 +3,11 @@ module MOM_stochastics ! This file is part of MOM6. See LICENSE.md for the license. -! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, termination and update of ocean model state. This -! particular version wraps all of the calls for MOM6 in the calls that had -! been used for MOM4. -! -! This code is a stop-gap wrapper of the MOM6 code to enable it to be called -! in the same way as MOM4. +! This is the top level module for the MOM6 ocean model. It contains +! placeholder for initialization, update, and writing restarts of ocean stochastic physics. +! The actualy stochastic physics is available at +! https://github.com/ufs-community/ufs-weather-model +! use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type use MOM_grid, only : ocean_grid_type @@ -62,6 +60,9 @@ subroutine update_stochastics(CS) type(stochastic_CS), intent(inout) :: CS !< diabatic control structure return end subroutine update_stochastics - +subroutine write_mom_restart_stoch(filename) + character(len=*) :: filename + return +end subroutine write_mom_restart_stoch end module MOM_stochastics diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a0594290ee..f62eb6a4fe 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -663,7 +663,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call disable_averaging(CS%diag) endif endif - + ! advance the random pattern if stochastic physics is active if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then @@ -2497,8 +2497,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (.not. CS%rotate_index) & G => G_in - ! initialize stochastic physics - !call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 319a6f2be6..2b15c67899 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -313,7 +313,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (G%ke == 1) return - ! save copy of the date for SPPT + ! save copy of the date for SPPT if active if (stoch_CS%do_sppt) then allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) From aac6b75dd7d095a37f9db988acb239cf868ed0b3 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Mon, 16 Aug 2021 08:53:19 -0400 Subject: [PATCH 114/155] update to gfdl 20210806 (#74) * remove white space and fix comment * Update MOM_oda_incupd.F90 remove unused index bounds, and fix sum_h2 loop. Co-authored-by: pjpegion Co-authored-by: Marshall Ward --- src/ocean_data_assim/MOM_oda_incupd.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index f087ad71c0..5f38fa15d0 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -415,7 +415,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) enddo endif enddo; enddo - + ! remap u to h_obs to get increment if (CS%uv_inc) then call pass_var(h, G%Domain) From 1428a36aca21be2dcb6532e273f15f7c8ba573e3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 21 Sep 2021 18:54:31 -0800 Subject: [PATCH 115/155] Several little things, one is making sponge less verbose. - Pointing to OBC wiki file from the lateral parameterizations doc. - Using the MOM6 verbosity to control the time_interp verbosity. - Making the check for negative water depths more informative. --- src/framework/MOM_horizontal_regridding.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index de511688a9..1204fc21b1 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -740,7 +740,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=(verbosity>5), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>2), 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 @@ -840,6 +840,14 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + ! now fill in missing values using "ICE-nine" algorithm. + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) + + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) ! endif @@ -856,7 +864,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=(verbosity>5), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>2), turns=turns) do k=1,kd do j=js,je do i=is,ie @@ -867,6 +875,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo enddo endif + end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. From a180d3316ed6eac746b3bd7ad5c3e6da989f2271 Mon Sep 17 00:00:00 2001 From: pjpegion Date: Tue, 28 Sep 2021 18:47:57 +0000 Subject: [PATCH 116/155] return a more accurate error message in MOM_stochasics --- .../external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 index 427b3c754b..e6b0c80280 100644 --- a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 +++ b/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 @@ -101,9 +101,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) if (iret/=0) then - write(6,*) 'call to init_stochastic_physics_ocn failed' - call MOM_error(FATAL, "stochastic physics in enambled in MOM6 but "// & - "not activated in stochastic_physics namelist ") + call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") return endif From 918742bbba627eeb078babc37a5dcaa53fddfe53 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Oct 2021 10:57:33 -0800 Subject: [PATCH 117/155] Working on boundary layer docs. --- src/framework/MOM_horizontal_regridding.F90 | 4 +- src/parameterizations/vertical/_EPBL.dox | 184 +------------------- 2 files changed, 5 insertions(+), 183 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1204fc21b1..e5e651407e 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -740,7 +740,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=(verbosity>2), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. do k=1,kd @@ -864,7 +864,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=(verbosity>2), turns=turns) + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/parameterizations/vertical/_EPBL.dox b/src/parameterizations/vertical/_EPBL.dox index d531c9ad9a..6134de31e0 100644 --- a/src/parameterizations/vertical/_EPBL.dox +++ b/src/parameterizations/vertical/_EPBL.dox @@ -57,7 +57,7 @@ Similarly, the eddy diffusivity is used to parameterize turbulent scalar fluxes \f] The parameters needed to close the system of equations are then reduced to the turbulent -mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$. +mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$$. We start with an equation for the turbulent kinetic energy (TKE): @@ -67,188 +67,10 @@ We start with an equation for the turbulent kinetic energy (TKE): {\partial z} + \overline{w^\prime b^\prime} - \epsilon \f] + Terms in this equation represent TKE storage (LHS), TKE flux convergence, shear production, buoyancy production, and dissipation. -\section section_WMBL Well-mixed Boundary Layers (WMBL) - -Assuming steady state and other parameterizations, integrating vertically -over the surface boundary layer, \cite reichl2018 obtains the form: - -\f[ - \frac{1}{2} H_{bl} w_e \Delta b = m_\ast u_\ast^3 - n_\ast \frac{H_{bl}}{2} - B(H_{bl}) , -\f] - -with the following variables: - - - -
Symbols used in integrated TKE equation
Symbol Meaning -
\f$H_{bl}\f$ boundary layer thickness -
\f$w_e\f$ entrainment velocity -
\f$\Delta b\f$ change in buoyancy at base of mixed layer -
\f$m_\ast\f$ sum of mechanical coefficients -
\f$u_\ast\f$ friction velocity (\f$u_\ast = (|\tau| / \rho_0)^{1/2}\f$) -
\f$\tau\f$ wind stress -
\f$n_\ast\f$ convective proportionality coefficient -
1 for stabilizing surface buoyancy flux, less otherwise -
\f$B(H_{bl})\f$ surface buoyancy flux -
- -\section section_ePBL Energetics-based Planetary Boundary Layer - -Once again, the goal is to formulate a surface mixing scheme to find the -turbulent eddy diffusivity (and viscosity) in a way that is suitable for use -in a global climate model, using long timesteps and large grid spacing. -After evaluating a well-mixed boundary layer (WMBL), the shear mixing of -\cite jackson2008 (JHL, \ref subsection_kappa_shear), as well as a more complete -boundary layer scheme, it was decided to combine a number of these ideas -into a new scheme: - -\f[ - K(z) = F_x(K_{ePBL}(z), K_{JHL}(z), K_n(z)) -\f] - -where \f$F_x\f$ is some unknown function of a new \f$K_{ePBL}\f$, -\f$K_{JHL}\f$, the diffusivity due to shear as determined by -\cite jackson2008, and \f$K_n\f$, the diffusivity from other ideas. -We start by specifying the form of \f$K_{ePBL}\f$ as being: - -\f[ - K_{ePBL}(z) = C_K w_t l , -\f] - -where \f$w_t\f$ is a turbulent velocity scale, \f$C_K\f$ is a coefficient, and -\f$l\f$ is a length scale. - -\subsection subsection_lengthscale Turbulent length scale - -We propose a form for the length scale as follows: - -\f[ - l = (z_0 + |z|) \times \max \left[ \frac{l_b}{H_{bl}} , \left( - \frac{H_{bl} - |z|}{H_{bl}} \right)^\gamma \, \right] , -\f] - -where we have the following variables: - - - -
Symbols used in ePBL length scale
Symbol Meaning -
\f$H_{bl}\f$ boundary layer thickness -
\f$z_0\f$ roughness length -
\f$\gamma\f$ coefficient, 2 is as in KPP, \cite large1994 -
\f$l_b\f$ bottom length scale -
- -\subsection subsection_velocityscale Turbulent velocity scale - -We do not predict the TKE prognostically and therefore approximate the vertical TKE -profile to estimate \f$w_t\f$. An estimate for the mechanical contribution to the velocity -scale follows the standard two-equation approach. In one and two-equation second-order -\f$K\f$ parameterizations the boundary condition for the TKE is typically employed as a -flux boundary condition. - -\f[ - K \left. \frac{\partial k}{\partial z} \right|_{z=0} = c_\mu^0 u_\ast^3 . -\f] - -The profile of \f$k\f$ decays in the vertical from \f$k \propto (c_\mu^0)^{2/3} -u_\ast^2\f$ toward the base of the OSBL. Here we assume a similar relationship to estimate -the mechanical contribution to the TKE profile. The value of \f$w_t\f$ due to mechanical -sources, \f$v_\ast\f$, is estimate as \f$v_\ast (z=0) \propto (c_\mu^0)^{1/3} u_\ast\f$ at -the surface. Since we only parameterize OSBL turbulent mixing due to surface forcing, the -value of the velocity scale is assumed to decay moving away from the surface. For -simplicity we employ a linear decay in depth: - -\f[ - v_\ast (z) = (c_\mu^0)^{1/3} u_\ast \left( 1 - a \cdot \min \left[ 1, - \frac{|z|}{H_{bl}} \right] \right) , -\f] - -where \f$1 > a > 0\f$ has the effect of making \f$v_\ast(z=H_{bl}) > 0\f$. -Making the constant coefficient \f$a\f$ close to one has the effect of reducing the mixing -rate near the base of the boundary layer, thus producing a more diffuse entrainment -region. Making \f$a\f$ close to zero has the effect of increasing the mixing at the base -of the boundary layer, producing a more 'step-like' entrainment region. - -An estimate for the buoyancy contribution is found utilizing the convective velocity -scale: - -\f[ - w_\ast (z) = C_{w_\ast} \left( \int_z^0 \overline{w^\prime b^\prime} dz \right)^{1/3} , -\f] - -where \f$C_{w_\ast}\f$ is a non-dimensional empirical coefficient. Convection in one and -two-equation closure causes a TKE profile that peaks below the surface. The quantity -\f$\overline{w^\prime b^\prime}\f$ is solved for in ePBL as \f$KN^2\f$. - -These choices for the convective and mechanical components of the velocity scale in the -OSBL are then added together to get an estimate for the total turbulent velocity scale: - -\f[ - w_t (z) = w_\ast (z) + v_\ast (z) . -\f] - -The value of \f$a\f$ is arbitrarily chosen to be 0.95 here. - -\subsection subsection_ePBL_summary Summarizing the ePBL implementation - -The ePBL mixing coefficient is found by multiplying a velocity scale -(\ref subsection_velocityscale) by a length scale (\ref subsection_lengthscale). The -precise value of the coefficient \f$C_K\f$ used does not significantly alter the -prescribed potential energy change constraint. A reasonable value is \f$C_K \approx 0.55\f$ to -be consistent with other approaches (e.g. \cite umlauf2005). - -The boundary layer thickness (\f$H_{bl}\f$) within ePBL is based on -the depth where the energy requirement for turbulent mixing of density -exceeds the available energy (\ref section_WMBL). \f$H_{bl}\f$ is -determined by the energetic constraint imposed using the value of -\f$m_\ast\f$ and \f$n_\ast\f$. An iterative solver is required because -\f$m_\ast\f$ and the mixing length are dependent on \f$H_{bl}\f$. - -We use a constant value for convectively driven TKE of \f$n_\ast = 0.066\f$. The -parameterizations for \f$m_\ast\f$ are formulated specifically for the regimes where -\f$K_{JHL}\f$ is sensitive to model numerics \f$(|f| \Delta t \approx -1)\f$ (\cite reichl2018). - -\subsection subsection_ePBL_JHL Combining ePBL and JHL mixing coefficients - -We now address the combination of the ePBL mixing coefficient and the JHL mixing -coefficient. The function \f$F_x\f$ above cannot be the linear sum of \f$K_{ePBL}\f$ and -\f$K_{JHL}\f$. One reason this sum is not valid is because the JHL mixing coefficient is -determined by resolved current shear, including that driven by the surface wind. The -wind-driven current is also included in the ePBL mixing coefficient formulation. An -alternative approach is therefore needed to avoid double counting. - -\f$K_{ePBL}\f$ is not used at the equator as scalings are only investigated when \f$|f| > -0\f$. The solution we employ is to use the maximum mixing coefficient of the two -contributions, - -\f[ - K (z) = \max (K_{ePBL} (z), K_{JHL} (z)), -\f] - -where \f$m_\ast\f$ (and hence \f$K_{ePBL}\f$) is constrained to be small as \f$|f| -\rightarrow 0\f$. This form uses the JHL mixing coefficient when the ePBL coefficient is -small. - -This approach is reasonable when the wind-driven mixing dominates, since both JHL and ePBL -give a similar solution when deployed optimally. One weakness of this approach is the -tropical region, where the shear-driven ePBL \f$m_\ast\f$ coefficient is not formulated. -The JHL parameterization is skillful to simulate this mixing, but does not include the -contribution of convection. The convective portion of \f$K_{ePBL}\f$ should be combined -with \f$K_{JHL}\f$ in the equatorial region when shear and convection occur together. -Future research is warranted. - -Finally, one should note that the mixing coefficient here (\f$K\f$) is used for both -diffusivity and viscosity, implying a turbulent Prandtl number of 1.0. - -\subsection subsection_Langmuir Langmuir circulation - -While only briefly alluded to in \cite reichl2018, the MOM6 code implementing ePBL does -support the option to add a Langmuir parameterization. There are in fact two options, both -adjusting \f$m_\ast\f$. +Following the lead of \cite jackson2008 (\ref subsection_kappa_shear). */ From 11fa1140629e8334b90fa221450879816a90cce6 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Oct 2021 13:46:54 -0800 Subject: [PATCH 118/155] Done with EPBL docs? --- docs/conf.py | 2 +- src/parameterizations/vertical/_EPBL.dox | 184 ++++++++++++++++++++++- 2 files changed, 182 insertions(+), 4 deletions(-) diff --git a/docs/conf.py b/docs/conf.py index 4407d88356..5d84b3c37a 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -159,7 +159,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # General information about the project. project = u'MOM6' -copyright = u'2017-2022, MOM6 developers' +copyright = u'2017-2021, MOM6 developers' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the diff --git a/src/parameterizations/vertical/_EPBL.dox b/src/parameterizations/vertical/_EPBL.dox index 6134de31e0..d531c9ad9a 100644 --- a/src/parameterizations/vertical/_EPBL.dox +++ b/src/parameterizations/vertical/_EPBL.dox @@ -57,7 +57,7 @@ Similarly, the eddy diffusivity is used to parameterize turbulent scalar fluxes \f] The parameters needed to close the system of equations are then reduced to the turbulent -mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$$. +mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$. We start with an equation for the turbulent kinetic energy (TKE): @@ -67,10 +67,188 @@ We start with an equation for the turbulent kinetic energy (TKE): {\partial z} + \overline{w^\prime b^\prime} - \epsilon \f] - Terms in this equation represent TKE storage (LHS), TKE flux convergence, shear production, buoyancy production, and dissipation. -Following the lead of \cite jackson2008 (\ref subsection_kappa_shear). +\section section_WMBL Well-mixed Boundary Layers (WMBL) + +Assuming steady state and other parameterizations, integrating vertically +over the surface boundary layer, \cite reichl2018 obtains the form: + +\f[ + \frac{1}{2} H_{bl} w_e \Delta b = m_\ast u_\ast^3 - n_\ast \frac{H_{bl}}{2} + B(H_{bl}) , +\f] + +with the following variables: + + + +
Symbols used in integrated TKE equation
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$w_e\f$ entrainment velocity +
\f$\Delta b\f$ change in buoyancy at base of mixed layer +
\f$m_\ast\f$ sum of mechanical coefficients +
\f$u_\ast\f$ friction velocity (\f$u_\ast = (|\tau| / \rho_0)^{1/2}\f$) +
\f$\tau\f$ wind stress +
\f$n_\ast\f$ convective proportionality coefficient +
1 for stabilizing surface buoyancy flux, less otherwise +
\f$B(H_{bl})\f$ surface buoyancy flux +
+ +\section section_ePBL Energetics-based Planetary Boundary Layer + +Once again, the goal is to formulate a surface mixing scheme to find the +turbulent eddy diffusivity (and viscosity) in a way that is suitable for use +in a global climate model, using long timesteps and large grid spacing. +After evaluating a well-mixed boundary layer (WMBL), the shear mixing of +\cite jackson2008 (JHL, \ref subsection_kappa_shear), as well as a more complete +boundary layer scheme, it was decided to combine a number of these ideas +into a new scheme: + +\f[ + K(z) = F_x(K_{ePBL}(z), K_{JHL}(z), K_n(z)) +\f] + +where \f$F_x\f$ is some unknown function of a new \f$K_{ePBL}\f$, +\f$K_{JHL}\f$, the diffusivity due to shear as determined by +\cite jackson2008, and \f$K_n\f$, the diffusivity from other ideas. +We start by specifying the form of \f$K_{ePBL}\f$ as being: + +\f[ + K_{ePBL}(z) = C_K w_t l , +\f] + +where \f$w_t\f$ is a turbulent velocity scale, \f$C_K\f$ is a coefficient, and +\f$l\f$ is a length scale. + +\subsection subsection_lengthscale Turbulent length scale + +We propose a form for the length scale as follows: + +\f[ + l = (z_0 + |z|) \times \max \left[ \frac{l_b}{H_{bl}} , \left( + \frac{H_{bl} - |z|}{H_{bl}} \right)^\gamma \, \right] , +\f] + +where we have the following variables: + + + +
Symbols used in ePBL length scale
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$z_0\f$ roughness length +
\f$\gamma\f$ coefficient, 2 is as in KPP, \cite large1994 +
\f$l_b\f$ bottom length scale +
+ +\subsection subsection_velocityscale Turbulent velocity scale + +We do not predict the TKE prognostically and therefore approximate the vertical TKE +profile to estimate \f$w_t\f$. An estimate for the mechanical contribution to the velocity +scale follows the standard two-equation approach. In one and two-equation second-order +\f$K\f$ parameterizations the boundary condition for the TKE is typically employed as a +flux boundary condition. + +\f[ + K \left. \frac{\partial k}{\partial z} \right|_{z=0} = c_\mu^0 u_\ast^3 . +\f] + +The profile of \f$k\f$ decays in the vertical from \f$k \propto (c_\mu^0)^{2/3} +u_\ast^2\f$ toward the base of the OSBL. Here we assume a similar relationship to estimate +the mechanical contribution to the TKE profile. The value of \f$w_t\f$ due to mechanical +sources, \f$v_\ast\f$, is estimate as \f$v_\ast (z=0) \propto (c_\mu^0)^{1/3} u_\ast\f$ at +the surface. Since we only parameterize OSBL turbulent mixing due to surface forcing, the +value of the velocity scale is assumed to decay moving away from the surface. For +simplicity we employ a linear decay in depth: + +\f[ + v_\ast (z) = (c_\mu^0)^{1/3} u_\ast \left( 1 - a \cdot \min \left[ 1, + \frac{|z|}{H_{bl}} \right] \right) , +\f] + +where \f$1 > a > 0\f$ has the effect of making \f$v_\ast(z=H_{bl}) > 0\f$. +Making the constant coefficient \f$a\f$ close to one has the effect of reducing the mixing +rate near the base of the boundary layer, thus producing a more diffuse entrainment +region. Making \f$a\f$ close to zero has the effect of increasing the mixing at the base +of the boundary layer, producing a more 'step-like' entrainment region. + +An estimate for the buoyancy contribution is found utilizing the convective velocity +scale: + +\f[ + w_\ast (z) = C_{w_\ast} \left( \int_z^0 \overline{w^\prime b^\prime} dz \right)^{1/3} , +\f] + +where \f$C_{w_\ast}\f$ is a non-dimensional empirical coefficient. Convection in one and +two-equation closure causes a TKE profile that peaks below the surface. The quantity +\f$\overline{w^\prime b^\prime}\f$ is solved for in ePBL as \f$KN^2\f$. + +These choices for the convective and mechanical components of the velocity scale in the +OSBL are then added together to get an estimate for the total turbulent velocity scale: + +\f[ + w_t (z) = w_\ast (z) + v_\ast (z) . +\f] + +The value of \f$a\f$ is arbitrarily chosen to be 0.95 here. + +\subsection subsection_ePBL_summary Summarizing the ePBL implementation + +The ePBL mixing coefficient is found by multiplying a velocity scale +(\ref subsection_velocityscale) by a length scale (\ref subsection_lengthscale). The +precise value of the coefficient \f$C_K\f$ used does not significantly alter the +prescribed potential energy change constraint. A reasonable value is \f$C_K \approx 0.55\f$ to +be consistent with other approaches (e.g. \cite umlauf2005). + +The boundary layer thickness (\f$H_{bl}\f$) within ePBL is based on +the depth where the energy requirement for turbulent mixing of density +exceeds the available energy (\ref section_WMBL). \f$H_{bl}\f$ is +determined by the energetic constraint imposed using the value of +\f$m_\ast\f$ and \f$n_\ast\f$. An iterative solver is required because +\f$m_\ast\f$ and the mixing length are dependent on \f$H_{bl}\f$. + +We use a constant value for convectively driven TKE of \f$n_\ast = 0.066\f$. The +parameterizations for \f$m_\ast\f$ are formulated specifically for the regimes where +\f$K_{JHL}\f$ is sensitive to model numerics \f$(|f| \Delta t \approx +1)\f$ (\cite reichl2018). + +\subsection subsection_ePBL_JHL Combining ePBL and JHL mixing coefficients + +We now address the combination of the ePBL mixing coefficient and the JHL mixing +coefficient. The function \f$F_x\f$ above cannot be the linear sum of \f$K_{ePBL}\f$ and +\f$K_{JHL}\f$. One reason this sum is not valid is because the JHL mixing coefficient is +determined by resolved current shear, including that driven by the surface wind. The +wind-driven current is also included in the ePBL mixing coefficient formulation. An +alternative approach is therefore needed to avoid double counting. + +\f$K_{ePBL}\f$ is not used at the equator as scalings are only investigated when \f$|f| > +0\f$. The solution we employ is to use the maximum mixing coefficient of the two +contributions, + +\f[ + K (z) = \max (K_{ePBL} (z), K_{JHL} (z)), +\f] + +where \f$m_\ast\f$ (and hence \f$K_{ePBL}\f$) is constrained to be small as \f$|f| +\rightarrow 0\f$. This form uses the JHL mixing coefficient when the ePBL coefficient is +small. + +This approach is reasonable when the wind-driven mixing dominates, since both JHL and ePBL +give a similar solution when deployed optimally. One weakness of this approach is the +tropical region, where the shear-driven ePBL \f$m_\ast\f$ coefficient is not formulated. +The JHL parameterization is skillful to simulate this mixing, but does not include the +contribution of convection. The convective portion of \f$K_{ePBL}\f$ should be combined +with \f$K_{JHL}\f$ in the equatorial region when shear and convection occur together. +Future research is warranted. + +Finally, one should note that the mixing coefficient here (\f$K\f$) is used for both +diffusivity and viscosity, implying a turbulent Prandtl number of 1.0. + +\subsection subsection_Langmuir Langmuir circulation + +While only briefly alluded to in \cite reichl2018, the MOM6 code implementing ePBL does +support the option to add a Langmuir parameterization. There are in fact two options, both +adjusting \f$m_\ast\f$. */ From 4a91628395dd97182ff03563adaf55463315e375 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Oct 2021 14:53:52 -0800 Subject: [PATCH 119/155] Undoing some patches from others --- src/core/MOM_barotropic.F90 | 32 +++------------------ src/framework/MOM_horizontal_regridding.F90 | 9 ------ 2 files changed, 4 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3b5c812ba1..7d9c4facb2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -225,10 +225,7 @@ module MOM_barotropic !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. logical :: tides !< If true, apply tidal momentum forcing. - logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the - !! barotropic solver has the wrong sign, replicating a long-standing - !! bug. - real :: G_extra !< A nondimensional factor by which gtot is enhanced [nondim]. + real :: G_extra !< A nondimensional factor by which gtot is enhanced. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are !! given by the parameters defined below: @@ -1057,11 +1054,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%tides) then call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - if (CS%tidal_sal_bug) then - dgeo_de = 1.0 + det_de + CS%G_extra - else - dgeo_de = (1.0 - det_de) + CS%G_extra - endif + dgeo_de = 1.0 + det_de + CS%G_extra else dgeo_de = 1.0 + CS%G_extra endif @@ -2804,11 +2797,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) det_de = 0.0 if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - if (CS%tidal_sal_bug) then - dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) - else - dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de) - endif + dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) if (present(pbce)) then do j=js,je ; do i=is,ie gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 @@ -4299,12 +4288,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. - real :: det_de ! The partial derivative due to self-attraction and loading of the reference - ! geopotential with the sea surface height when tides are enabled. - ! This is typically ~0.09 or less. - real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points - ! that acts on the barotropic flow [Z T-1 ~> m s-1]. - + real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity @@ -4458,14 +4442,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) - det_de = 0.0 - if (CS%tides .and. associated(CS%tides_CSp)) & - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & - "If true, the tidal self-attraction and loading anomaly in the barotropic "//& - "solver has the wrong sign, replicating a long-standing bug with a scalar "//& - "self-attraction and loading term or the SAL term from a previous simulation.", & - default=.true., do_not_log=(det_de==0.0)) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index e5e651407e..de511688a9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -840,14 +840,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) - ! now fill in missing values using "ICE-nine" algorithm. - tr_outf(:,:) = tr_out(:,:) - if (k==1) tr_prev(:,:) = tr_outf(:,:) - good2(:,:) = good(:,:) - fill2(:,:) = fill(:,:) - - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) - ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) ! endif @@ -875,7 +867,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo enddo endif - end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. From 28003a8f76c057a284ec23944361178729f45148 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 12 Oct 2021 11:01:28 -0800 Subject: [PATCH 120/155] Adding in that SAL commit again. --- src/core/MOM_barotropic.F90 | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7d9c4facb2..48fb35e1b8 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -225,6 +225,9 @@ module MOM_barotropic !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. logical :: tides !< If true, apply tidal momentum forcing. + logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the + !! barotropic solver has the wrong sign, replicating a long-standing + !! bug. real :: G_extra !< A nondimensional factor by which gtot is enhanced. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are @@ -1054,7 +1057,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%tides) then call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - dgeo_de = 1.0 + det_de + CS%G_extra + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + det_de + CS%G_extra + else + dgeo_de = (1.0 - det_de) + CS%G_extra + endif else dgeo_de = 1.0 + CS%G_extra endif @@ -2797,7 +2804,11 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) det_de = 0.0 if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) - dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) + else + dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de) + endif if (present(pbce)) then do j=js,je ; do i=is,ie gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 @@ -4288,6 +4299,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. + real :: det_de ! The partial derivative due to self-attraction and loading of the reference + ! geopotential with the sea surface height when tides are enabled. + ! This is typically ~0.09 or less. real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4442,6 +4456,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + det_de = 0.0 + if (CS%tides .and. associated(CS%tides_CSp)) & + call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & + "If true, the tidal self-attraction and loading anomaly in the barotropic "//& + "solver has the wrong sign, replicating a long-standing bug with a scalar "//& + "self-attraction and loading term or the SAL term from a previous simulation.", & + default=.true., do_not_log=(det_de==0.0)) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& From 1853352a65bfcf0724edb39bad6fcf43422e4b10 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Thu, 28 Oct 2021 15:47:25 -0400 Subject: [PATCH 121/155] correction on type in directory name --- .../MOM_stochastics.F90 | 0 .../MOM_stochastics_stub.F90 | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename config_src/external/{OCEAN_stochastic_phyiscs => OCEAN_stochastic_physics}/MOM_stochastics.F90 (100%) rename config_src/external/{OCEAN_stochastic_phyiscs => OCEAN_stochastic_physics}/MOM_stochastics_stub.F90 (100%) diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 similarity index 100% rename from config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics.F90 rename to config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 diff --git a/config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 similarity index 100% rename from config_src/external/OCEAN_stochastic_phyiscs/MOM_stochastics_stub.F90 rename to config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 From 6f48b9d1d1499a2e3761f89cfb1fd993235536c3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 28 Jan 2022 11:24:39 -0900 Subject: [PATCH 122/155] Oops, more cleanup. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 17 +-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 19 ++-- config_src/drivers/solo_driver/MOM_driver.F90 | 14 --- .../MOM_stochastics_stub.F90 | 68 ------------ docs/conf.py | 2 +- src/core/MOM.F90 | 37 ++++--- src/core/MOM_barotropic.F90 | 6 +- src/diagnostics/MOM_diagnostics.F90 | 4 +- src/framework/MOM_domains.F90 | 60 ++++++++--- .../stochastic}/MOM_stochastics.F90 | 35 +++--- .../vertical/MOM_diabatic_driver.F90 | 63 +++++------ .../vertical/MOM_energetic_PBL.F90 | 102 +++++++----------- 12 files changed, 167 insertions(+), 260 deletions(-) delete mode 100644 config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 rename {config_src/external/OCEAN_stochastic_physics => src/parameterizations/stochastic}/MOM_stochastics.F90 (86%) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 25de32d526..174a659f12 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -98,7 +98,6 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -use MOM_stochastics, only : write_mom_restart_stoch !$use omp_lib , only : omp_set_num_threads implicit none; private @@ -1750,21 +1749,9 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + call ocean_model_restart(ocean_state, restartname=restartname, & + stoch_restartname=stoch_restartname) - if (ocean_state%do_sppt .OR. ocean_state%pert_epbl) then - if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"ocn_stoch.res.nc" - else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" - endif - call ESMF_LogWrite("MOM_cap: Writing stoch restart : "//trim(restartname), & - ESMF_LOGMSG_INFO) - call write_mom_restart_stoch('RESTART/'//trim(restartname)) - endif - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - call write_stoch_restart_ocn('RESTART/'//trim(restartname)) endif if (is_root_pe()) then diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 9ffe4cd794..448f23140e 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -62,8 +62,8 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart -use MOM_domains, only : root_PE,num_PEs -use MOM_coms, only : Get_PElist +use get_stochy_pattern_mod, only : write_stoch_restart_ocn +use iso_fortran_env, only : int64 #include @@ -177,8 +177,10 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical,public :: do_sppt !< If true, write stochastic physics restarts - logical,public :: pert_epbl !< If true, write stochastic physics restarts + logical :: do_sppt !< If true, stochastically perturb the diabatic and + !! write restarts + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and + !! genration termsand write restarts real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -253,7 +255,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot!< If true, allocate melt_potential array + logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: use_CFC !< If true, allocated arrays for surface CFCs. + ! This include declares and sets the variable "version". #include "version_variable.h" @@ -425,10 +429,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i endif - ! check to see if stochastic physics is active + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) +! get number of processors and PE list for stocasthci physics initialization call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "tendencies of T,S, and h. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) call get_param(param_file, mdl, "PERT_EPBL", OS%pert_epbl, & diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 8ed8a8559f..c2cd0a248c 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -71,19 +71,6 @@ program MOM_main use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS - 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 - use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart -! , add_shelf_flux_forcing, add_shelf_flux_IOB - - 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 #include @@ -93,7 +80,6 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes - ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state diff --git a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 b/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 deleted file mode 100644 index 349d56c0c7..0000000000 --- a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics_stub.F90 +++ /dev/null @@ -1,68 +0,0 @@ -!> Top-level module for the MOM6 ocean model in coupled mode. -module MOM_stochastics - -! This file is part of MOM6. See LICENSE.md for the license. - -! This is the top level module for the MOM6 ocean model. It contains -! placeholder for initialization, update, and writing restarts of ocean stochastic physics. -! The actualy stochastic physics is available at -! https://github.com/ufs-community/ufs-weather-model -! - -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -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 MOM_domains, only : root_PE,num_PEs -use MOM_coms, only : Get_PElist - -#include - -implicit none ; private - -public stochastics_init, update_stochastics - -!> This control structure holds parameters for the MOM_stochastics module -type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - !>@{ Diagnostic IDs - integer :: id_sppt_wts = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 - !>@} - ! stochastic patterns - real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - !! tendencies with a number between 0 and 2 - real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation - real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output - type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) -end type stochastic_CS - -contains - -subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) - real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid ! horizontal grid information - type(verticalGrid_type), intent(in) :: GV ! vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output - type(time_type), target :: Time !< model time - return -end subroutine stochastics_init - -subroutine update_stochastics(CS) - type(stochastic_CS), intent(inout) :: CS !< diabatic control structure - return -end subroutine update_stochastics -subroutine write_mom_restart_stoch(filename) - character(len=*) :: filename - return -end subroutine write_mom_restart_stoch -end module MOM_stochastics - diff --git a/docs/conf.py b/docs/conf.py index 5d84b3c37a..4407d88356 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -159,7 +159,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # General information about the project. project = u'MOM6' -copyright = u'2017-2021, MOM6 developers' +copyright = u'2017-2022, MOM6 developers' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f62eb6a4fe..f3d8869320 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -133,7 +133,7 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_variables, only : rotate_surface_state, stochastic_pattern +use MOM_variables, only : rotate_surface_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -155,6 +155,8 @@ 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, initialize_ice_shelf +use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end implicit none ; private @@ -403,6 +405,16 @@ module MOM type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling !! ensemble model state vectors and data assimilation !! increments and priors + type(porous_barrier_ptrs) :: pbv !< porous barrier fractional cell metrics + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) & + :: por_face_areaU !< fractional open area of U-faces [nondim] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) & + :: por_face_areaV !< fractional open area of V-faces [nondim] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) & + :: por_layer_widthU !< fractional open width of U-faces [nondim] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) & + :: por_layer_widthV !< fractional open width of V-faces [nondim] + type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure end type MOM_control_struct @@ -1382,7 +1394,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & - Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS,OBC=CS%OBC, Waves=Waves) + Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1800,7 +1812,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - real :: conv2watt, conv2salt + real :: conv2watt ! A conversion factor from temperature fluxes to heat + ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] + real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -2477,28 +2492,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif - ! Shift from using the temporary dynamic grid type to using the final - ! (potentially static) ocean-specific grid type. - ! The next line would be needed if G%Domain had not already been init'd above: - ! call clone_MOM_domain(dG%Domain, G%Domain) - call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG, G, US) - call destroy_dyn_horgrid(dG) - ! Set a few remaining fields that are specific to the ocean grid type. if (CS%rotate_index) then call set_first_direction(G, modulo(first_direction + turns, 2)) else call set_first_direction(G, modulo(first_direction, 2)) endif - call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) - call destroy_dyn_horgrid(dG_in) - - if (.not. CS%rotate_index) & - G => G_in - ! Set a few remaining fields that are specific to the ocean grid type. - call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 48fb35e1b8..3b5c812ba1 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -228,7 +228,7 @@ module MOM_barotropic logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the !! barotropic solver has the wrong sign, replicating a long-standing !! bug. - real :: G_extra !< A nondimensional factor by which gtot is enhanced. + real :: G_extra !< A nondimensional factor by which gtot is enhanced [nondim]. integer :: hvel_scheme !< An integer indicating how the thicknesses at !! velocity points are calculated. Valid values are !! given by the parameters defined below: @@ -4302,7 +4302,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, real :: det_de ! The partial derivative due to self-attraction and loading of the reference ! geopotential with the sea surface height when tides are enabled. ! This is typically ~0.09 or less. - real, allocatable, dimension(:,:) :: lin_drag_h + real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points + ! that acts on the barotropic flow [Z T-1 ~> m s-1]. + type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 27164c2c75..ef71d9286c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1286,8 +1286,8 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> s]. type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< Time mean surface height without corrections + !! for ice displacement [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index aedf9d5d0d..dc6c0a8996 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,24 +3,56 @@ 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_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, group_pass_type +use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain +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 +use MOM_domain_infra, only : start_group_pass, complete_group_pass +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 +use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io_infra, only : file_exists use MOM_string_functions, only : slasher 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 :: 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 :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER +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 +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! Domain query routines +public :: get_domain_extent, get_domain_components, get_global_shape, same_domain +public :: PE_here, root_PE, num_PEs +! Blocks are not actively used in MOM6, so this routine could be deprecated. +public :: compute_block_extent +! 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 :: 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 +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. diff --git a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 similarity index 86% rename from config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 rename to src/parameterizations/stochastic/MOM_stochastics.F90 index e6b0c80280..21a22a222e 100644 --- a/config_src/external/OCEAN_stochastic_physics/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -19,20 +19,20 @@ module MOM_stochastics use MOM_domains, only : root_PE,num_PEs use MOM_coms, only : Get_PElist use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn -use get_stochy_pattern_mod, only: write_stoch_restart_ocn #include implicit none ; private -public stochastics_init, update_stochastics, write_mom_restart_stoch +public stochastics_init, update_stochastics !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS - logical :: do_sppt !< If true, stochastically perturb the diabatic - logical :: pert_epbl !! If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 - integer :: id_epbl1_wts=-1,id_epbl2_wts=-1 + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT + integer :: id_epbl1_wts=-1 !< Diagnostic id for epbl generation perturbation + integer :: id_epbl2_wts=-1 !< Diagnostic id for epbl dissipation perturbation ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 @@ -47,9 +47,9 @@ module MOM_stochastics !! This subroutine initializes the stochastics physics control structure. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid ! horizontal grid information - type(verticalGrid_type), intent(in) :: GV ! vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS + type(ocean_grid_type), intent(in) :: grid !< horizontal grid information + type(verticalGrid_type), intent(in) :: GV !< vertical grid structure + type(stochastic_CS), pointer, intent(inout):: CS !< stochastic control structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(time_type), target :: Time !< model time @@ -59,7 +59,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics integer :: me ! my pe - integer :: master ! root pe + integer :: pe_zero ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo @@ -95,11 +95,11 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) num_procs=num_PEs() allocate(pelist(num_procs)) call Get_PElist(pelist,commID = mom_comm) - master=root_PE() + pe_zero=root_PE() nx = grid%ied - grid%isd + 1 ny = grid%jed - grid%jsd + 1 call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,master,mom_comm,iret) + CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) if (iret/=0) then call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") return @@ -140,16 +140,5 @@ subroutine update_stochastics(CS) return end subroutine update_stochastics -!< wrapper to write ocean stochastic restarts -subroutine write_mom_restart_stoch(filename) - character(len=*) :: filename - - call callTree_enter("write_mom_restart_stoch(), MOM_stochastics.F90") - - call write_stoch_restart_ocn(filename) - - return -end subroutine write_mom_restart_stoch - end module MOM_stochastics diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2b15c67899..c2b19d4160 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -71,7 +71,6 @@ module MOM_diabatic_driver use MOM_wave_interface, only : wave_parameters_CS use MOM_stochastics, only : stochastic_CS - implicit none ; private #include @@ -221,8 +220,6 @@ module MOM_diabatic_driver logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics - real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil - real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module @@ -283,8 +280,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -293,8 +291,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & @@ -305,9 +303,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable(:,:,:) :: s_in ! salinity before thermodynamics + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT @@ -327,7 +325,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + if (GV%ke == 1) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") @@ -504,12 +504,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo enddo enddo + deallocate(h_in) + deallocate(t_in) + deallocate(s_in) endif end subroutine diabatic -end subroutine diabatic - !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. @@ -523,10 +524,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] - type(forcing), intent(inout) :: fluxes !< points to forcing fields - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -534,7 +537,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -835,8 +838,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves) + CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -1111,8 +1113,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations @@ -1120,7 +1123,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1372,8 +1375,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL_CSp, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, & - waves=waves) + CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -3135,12 +3137,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & - 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & - 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', diag%axesT1, Time, & - 'random pattern for sppt', 'None') + if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + if ((CS%id_dvdt_dia > 0) .or. (CS%id_hf_dvdt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 9ecba8a7b8..99dd38135d 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -244,9 +244,8 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, dt_diag, & - last_call, dT_expected, dS_expected, Waves) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) 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 @@ -278,27 +277,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 s-1 ~> m2 s-1]. - type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous - !! call to mixedlayer_init. + !! [Z2 T-1 ~> m2 s-1]. + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. - real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less - !! than dt if there are two calls to mixedlayer [T ~> s]. - logical, optional, intent(in) :: last_call !< If true, this is the last call to - !! mixedlayer in the current time step, so - !! diagnostics will be written. The default - !! is .true. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dT_expected !< The values of temperature change that - !! should be expected when the returned - !! diffusivities are applied [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dS_expected !< The values of salinity change that - !! should be expected when the returned - !! diffusivities are applied [ppt]. - type(wave_parameters_CS), & - optional, pointer :: Waves !< Wave CS + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous ! This subroutine determines the diffusivities from the integrated energetics @@ -439,16 +422,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) + if (stoch_CS%pert_epbl) then ! stochastics are active call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j), & - i=i, j=j) + US, CS, eCD, Waves, G, i, j, & + epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & - US, CS, eCD, dt_diag=dt_diag, Waves=Waves, G=G, i=i, j=j) + US, CS, eCD, Waves, G, i, j) endif ! Copy the diffusivities to a 2-d array. @@ -488,30 +471,26 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS enddo ! j-loop - if (write_diags) then - if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) - if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) - if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) - if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) - if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) - if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) - if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) - if (CS%id_TKE_mech_decay > 0) & - call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) - if (CS%id_TKE_conv_decay > 0) & - call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) - if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) - if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) - if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) - if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - ! only write random patterns if running with stochastic physics, otherwise the - ! array is unallocated and will give an error - if (stoch_CS%pert_epbl) then - if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) - if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) - endif + if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) + if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) + if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) + if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) + if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) + if (stoch_CS%pert_epbl) then + if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) + if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif end subroutine energetic_PBL @@ -521,7 +500,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - dt_diag, Waves, G, epbl1_wt, epbl2_wt, i, j) + Waves, G, i, j, epbl1_wt, epbl2_wt) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -558,16 +537,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. - real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less - !! than dt if there are two calls to mixedlayer [T ~> s]. - type(wave_parameters_CS), & - optional, pointer :: Waves !< Wave CS for Langmuir turbulence - type(ocean_grid_type), & - optional, intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt ! random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt ! random number to perturb KE dissipation - integer, optional, intent(in) :: i !< The i-index to work on (used for Waves) - integer, optional, intent(in) :: j !< The i-index to work on (used for Waves) + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation + real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation + integer, intent(in) :: i !< The i-index to work on (used for Waves) + integer, intent(in) :: j !< The i-index to work on (used for Waves) ! This subroutine determines the diffusivities in a single column from the integrated energetics ! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes @@ -941,11 +916,10 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) else - mech_TKE = mech_TKE * exp_kh + mech_TKE = mech_TKE * exp_kh endif - !if ( i .eq. 10 .and. j .eq. 10 .and. k .eq. nz) print*,'mech TKE', mech_TKE ! Accumulate any convectively released potential energy to contribute ! to wstar and to drive penetrating convection. From 24f412d77ad848abc6bcc573fdeb6c974f3aa7fa Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 31 Mar 2022 12:02:08 -0800 Subject: [PATCH 123/155] Part of the fix for issue #54. --- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index de511688a9..709bc3fe52 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -860,7 +860,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t do k=1,kd do j=js,je do i=is,ie - tr_z(i,j,k)=data_in(i,j,k) + tr_z(i,j,k)=data_in(i,j,k) * conversion 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 diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 6b89a86b30..8578dd2c17 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -143,7 +143,7 @@ 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. This +!! points are included in the sponges. It also stores the target interface heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & Iresttime_u_in, Iresttime_v_in) @@ -965,7 +965,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) then nz_data = CS%Ref_val_u%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, US%m_s_to_L_T, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) @@ -1014,7 +1014,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) deallocate(sp_val, mask_u, mask_z, hsrc) nz_data = CS%Ref_val_v%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, sp_val, mask_z, z_in, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, US%m_s_to_L_T, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) From 1e6924e03009a31f023645264828018e16a52c67 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Apr 2022 09:24:14 -0800 Subject: [PATCH 124/155] More fixes for issue #54. - Scaling of OBC's dz_src. - Scaling of CS%IDatu in MOM_barotropic. --- src/core/MOM_barotropic.F90 | 12 ++++++------ src/core/MOM_open_boundary.F90 | 3 ++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3b5c812ba1..6bf22dc14e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1246,12 +1246,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & - CS%dy_Cu(I,j)*Htot_avg) ) + CS%dy_Cu(I,j)*Htot_avg) ) * GV%Z_to_H elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & - CS%dy_Cu(I,j)*Htot_avg) ) + CS%dy_Cu(I,j)*Htot_avg) ) * GV%Z_to_H else - CS%IDatu(I,j) = 1.0 / Htot_avg + CS%IDatu(I,j) = GV%Z_to_H / Htot_avg endif endif @@ -1272,12 +1272,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & - CS%dx_Cv(i,J)*Htot_avg) ) + CS%dx_Cv(i,J)*Htot_avg) ) * GV%Z_to_H elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & - CS%dx_Cv(i,J)*Htot_avg) ) + CS%dx_Cv(i,J)*Htot_avg) ) * GV%Z_to_H else - CS%IDatv(i,J) = 1.0 / Htot_avg + CS%IDatv(i,J) = GV%Z_to_H / Htot_avg endif endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6ce0940ddb..53152d75bc 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3940,7 +3940,8 @@ 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') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) + call time_interp_external(segment%field(m)%fid_dz, Time, tmp_buffer_in) + tmp_buffer_in(:,:,:) = tmp_buffer_in(:,:,:) * US%m_to_Z if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. if (segment%is_E_or_W & From f50551ce44145d8b489eaf7e1297a3d147daaee8 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 5 Apr 2022 13:22:53 -0800 Subject: [PATCH 125/155] Fix to Z_RESCALE bug in ePBL. --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..27583c43b3 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1076,7 +1076,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%wT_scheme==wT_from_cRoot_TKE) then vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - htot/MLD_guess) + Surface_Scale = max(0.05, 1.0 - htot * GV%H_to_Z / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) endif @@ -1125,7 +1125,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%wT_scheme==wT_from_cRoot_TKE) then vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - htot/MLD_guess) + Surface_Scale = max(0.05, 1. - htot * GV%H_to_Z / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) endif From 41757c7a502f65a1cb18f515fe938ea5408c7c43 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Apr 2022 10:18:57 -0800 Subject: [PATCH 126/155] Fix the rebase --- src/core/MOM_forcing_type.F90 | 2 ++ src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4a702d4c0e..bdf4823f81 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,6 +170,8 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux + !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index c2b19d4160..7b180f1d65 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -838,7 +838,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) @@ -1375,7 +1375,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) From 57a1a8ae2f7eed50283b53e6308f8bad2e6ecb7c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Apr 2022 15:50:46 -0800 Subject: [PATCH 127/155] Rest of fix for issue #54. --- src/ALE/MOM_ALE.F90 | 6 +++-- src/core/MOM_open_boundary.F90 | 24 ++++++++++++------- src/ocean_data_assim/MOM_oda_driver.F90 | 8 +++---- .../vertical/MOM_tidal_mixing.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +++-- 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index fa195d57eb..77f2613f0c 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -753,8 +753,10 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:), & + GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:), & + GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo ! starting grid for next iteration diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 53152d75bc..47061f9447 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4007,19 +4007,22 @@ 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) endif enddo else @@ -4034,7 +4037,8 @@ 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,:), & - GV%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,:), & + GV%H_subroundoff, GV%H_subroundoff) endif enddo endif @@ -4053,19 +4057,22 @@ 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) 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,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + GV%H_subroundoff, GV%H_subroundoff) endif enddo else @@ -4080,7 +4087,8 @@ 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,:), & - GV%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,:), & + GV%H_subroundoff, GV%H_subroundoff) endif enddo endif diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index fc76c23480..a4c59be85c 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -415,9 +415,9 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) ! 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,:)) + CS%nk, CS%h(i,j,:), T(i,j,:), GV%H_subroundoff, GV%H_subroundoff) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:)) + CS%nk, CS%h(i,j,:), S(i,j,:), GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -671,9 +671,9 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec do j=jsc,jec; do i=isc,iec call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T(i,j,:), & - G%ke, h(i,j,:), T_inc(i,j,:)) + G%ke, h(i,j,:), T_inc(i,j,:), GV%H_subroundoff, GV%H_subroundoff) call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S(i,j,:), & - G%ke, h(i,j,:), S_inc(i,j,:)) + G%ke, h(i,j,:), S_inc(i,j,:), GV%H_subroundoff, GV%H_subroundoff) enddo; enddo diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index be574b4356..4b9fc8e182 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -875,7 +875,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! 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,:), & - GV%ke, h_m, tidal_qe_md) + GV%ke, h_m, tidal_qe_md, GV%H_subroundoff, GV%H_subroundoff) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 227e3ffb06..71016f8d8e 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -618,8 +618,10 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ allocate(F_layer_z(nk), source=0.0) ! remap tracer to dz_top - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:)) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & + CS%H_subroundoff, CS%H_subroundoff) ! Calculate vertical indices containing the boundary layer in dz_top call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) From 4b218c07a0e58296003b8cc70149a08c42ebf5d9 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Apr 2022 22:16:14 -0800 Subject: [PATCH 128/155] Tweaks in response to Hallberg's comments. --- src/ALE/MOM_ALE.F90 | 13 +++++++++++-- src/core/MOM_barotropic.F90 | 8 ++++---- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 77f2613f0c..df4f16409c 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -719,6 +719,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal + real :: h_neglect, h_neglect_edge nz = GV%ke @@ -744,6 +745,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg if (present(dt)) & call ALE_update_regrid_weights(dt, CS) + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + do k = 1, n call do_group_pass(pass_T_S_h, G%domain) @@ -754,9 +763,9 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) enddo ; enddo ! starting grid for next iteration diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 6bf22dc14e..e46bfc7c37 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1245,11 +1245,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & - CS%dy_Cu(I,j)*Htot_avg) ) * GV%Z_to_H + CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & - CS%dy_Cu(I,j)*Htot_avg) ) * GV%Z_to_H + CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) else CS%IDatu(I,j) = GV%Z_to_H / Htot_avg endif From 936b11fb655881a0f1dc87731c1fa863af4ac3e0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 6 Apr 2022 14:51:32 -0400 Subject: [PATCH 129/155] Format string fixes; function index reorder This fixes several (extremely) minor issues in the source code which were detected as nonconformat by the `-pedantic` flag. None are serious, and none are likely to resolve any outstanding issues. The main benefit is that it allows us to apply the `-pedantic` flag into our testing, which can help to detect future issues. The issues which have been fixed are described below. * The `nX` edit descriptor must include the number of forward steps. The implicit single step (`1x == x`) is a compiler extension. * The no-advance line record write token `$` is a compiler extension which is not described in the standard. Non-advancement is handled with the `advance='no'` argument. * Edit descriptors in format statements must be separated by commas, even though many compilers will ignore missing commas if there is no ambiguity. * When line continuation tokens are applied to strings, they must appear at both the end of the first line and the beginning of the subsequent line. Most compilers do not require this second starting token. * In function descriptions, if a variable used in the declaration of another variable, such as an array index, then it must be declared before any other variables refers to it. For example, this is invalid: ``` function foo(i0, x) real :: x(i0:) integer :: i0 ``` and `i0` must be declared before `x`. --- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 4 +- .../GFDL_ocean_BGC/generic_tracer.F90 | 4 +- src/ALE/MOM_remapping.F90 | 26 +- src/core/MOM.F90 | 6 +- src/core/MOM_forcing_type.F90 | 4 +- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_PointAccel.F90 | 466 +++++++++--------- src/diagnostics/MOM_debugging.F90 | 6 +- src/diagnostics/MOM_sum_output.F90 | 6 +- src/framework/MOM_checksums.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 4 +- src/framework/MOM_diag_vkernels.F90 | 8 +- src/framework/MOM_domains.F90 | 2 +- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/framework/MOM_write_cputime.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +- src/tracer/MOM_neutral_diffusion.F90 | 24 +- src/tracer/MOM_tracer_advect.F90 | 4 +- 20 files changed, 291 insertions(+), 291 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 index e50f2ccf0b..b7ee7de684 100644 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -11,9 +11,9 @@ module FMS_coupler_util !> Get element and index of a boundary condition subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & is, ie, js, je, conversion) - real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values integer, intent(in) :: ilb !< Lower bounds integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted integer, intent(in) :: BC_index !< The boundary condition number being extracted integer, intent(in) :: BC_element !< The element of the boundary condition being extracted @@ -27,9 +27,9 @@ end subroutine extract_coupler_values !> Set element and index of a boundary condition subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& is, ie, js, je, conversion) - real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC integer, intent(in) :: ilb !< Lower bounds integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded integer, intent(in) :: BC_index !< The boundary condition number being set integer, intent(in) :: BC_element !< The element of the boundary condition being set diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 index 6bd445ae8b..42c386497a 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 @@ -69,13 +69,13 @@ end subroutine generic_tracer_coupler_accumulate subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& frunoff,grid_ht, current_wave_stress, sosga) + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt !< Mass per unit area of each layer [kg m-2] real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth [m] - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain integer, intent(in) :: tau !< Time step index of %field real, intent(in) :: dtts !< The time step for this call [s] real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Grid cell areas [m2] diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 82087eea24..ebe0f81743 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -516,13 +516,13 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_l, u_c) u_max = max(u_l, u_c) if (ppoly_r_E(i0,1) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,1) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max problem_detected = .true. endif endif @@ -530,27 +530,27 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_c, u_r) u_max = max(u_c, u_r) if (ppoly_r_E(i0,2) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,2) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max problem_detected = .true. endif endif if (i0 > 1) then if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) - write(0,'(5(a,1pe24.16,x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) + write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) problem_detected = .true. endif endif if (problem_detected) then write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) - write(0,'(3(a,1pe24.16,x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r + write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) @@ -1960,7 +1960,7 @@ logical function test_answer(verbose, n, u, u_true, label, tol) if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label + write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label do k = 1, n if (abs(u(k) - u_true(k)) > tolerance) then write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f3d8869320..0703e45696 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3551,7 +3551,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ig = i + G%HI%idg_offset ! Global i-index jg = j + G%HI%jdg_offset ! Global j-index if (use_temperature) then - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),8(a,es11.4,x))') & + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & @@ -3560,7 +3560,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) else - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),6(a,es11.4))') & + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & @@ -3577,7 +3577,7 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then - write(msg(1:240),'(3(a,i9,x))') 'There were a total of ',numberOfErrors, & + write(msg(1:240),'(3(a,i9,1x))') 'There were a total of ',numberOfErrors, & 'locations detected with extreme surface values!' call MOM_error(FATAL, trim(msg)) endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index bdf4823f81..ccd70cd9da 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -704,7 +704,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& - &" at ",1pg11.4,"E, "1pg11.4,"N.")') & + &" at ",1pg11.4,",E,",1pg11.4,"N.")') & Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(WARNING,mesg) @@ -3125,7 +3125,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & if (present(waves)) then; if (waves) then; if (.not. present(num_stk_bands)) then call MOM_error(FATAL,"Requested to & - initialize with waves, but no waves are present.") + &initialize with waves, but no waves are present.") endif if (num_stk_bands > 0) then if (.not.associated(forces%ustkb)) then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6ce0940ddb..bda0b2df38 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4777,7 +4777,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) if (color(i,j) /= color2(i,j)) then fatal_error = .True. write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & - "the masking of the outside grid points.")') i, j + &"the masking of the outside grid points.")') i, j call MOM_error(WARNING,"MOM register_tracer: "//mesg, all_print=.true.) endif if (color(i,j) == cout) G%bathyT(i,j) = min_depth diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index a4badaf8e7..e52feec697 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -147,7 +147,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E "F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, & G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt @@ -156,174 +156,174 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"u(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*um(I,j,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"u(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*um(I,j,k)) ; enddo if (prev_avail) then - write(file,'(/,"u(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_prev(I,j,k)) ; enddo + write(file,'(/,"u(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_prev(I,j,k)) ; enddo endif - write(file,'(/,"u(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_av(I,j,k)) ; enddo + write(file,'(/,"u(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_av(I,j,k)) ; enddo - write(file,'(/,"CFL u: ",$)') + write(file,'(/,"CFL u: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(um(I,j,k)) * dt * G%dy_Cu(I,j) if (um(I,j,k) < 0.0) then ; CFL = CFL * G%IareaT(i+1,j) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 u:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 u:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(um(I,j,k)) * dt * G%IdxCu(I,j) ; enddo if (prev_avail) then - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(um(I,j,k)-CS%u_prev(I,j,k))) ; enddo endif - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEu(I,j,k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"ubv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"ubv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(um(I,j,k) - dt*ADp%du_dt_visc(I,j,k)) ; enddo - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%du_dt_visc(I,j,k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%du_other(I,j,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(I,j,k)*dt) ; enddo + write(file,'(/,"a: ")', advance='no') + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(I,j,k)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(I,j,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(I,j,k) ; enddo endif write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%u_accel_bt)) then - write(file,'("dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'("dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%u_accel_bt(I,j,k)) ; enddo write(file,'(/)') endif - write(file,'(/,"h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j-1,k)) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j-1,k)) ; enddo - write(file,'(/,"h-0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j,k)) ; enddo - write(file,'(/,"h+0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j,k)) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j+1,k)) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j+1,k)) ; enddo + write(file,'(/,"h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j-1,k)) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j-1,k)) ; enddo + write(file,'(/,"h-0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j,k)) ; enddo + write(file,'(/,"h+0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j,k)) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j+1,k)) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j+1,k)) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i+1,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i+1,j,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i+1,j,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i+1,j,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i+1,j,k) ; enddo endif if (prev_avail) then - write(file,'(/,"v--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo - write(file,'(/,"v-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo - write(file,'(/,"v+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo - write(file,'(/,"v++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo - endif - - write(file,'(/,"vh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"v--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo + write(file,'(/,"v-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo + write(file,'(/,"v++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo + endif + + write(file,'(/,"vh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)) ; enddo - write(file,'(/," vhC--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"vh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)) ; enddo - write(file,'(/," vhC-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"vh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)) ; enddo - write(file,'(/," vhC+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"vh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)) ; enddo - write(file,'(/," vhC++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo endif @@ -337,48 +337,48 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / du enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((um(I,j,k)-CS%u_prev(I,j,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffu(I,j,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEu(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) * Inorm(k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%du_dt_visc(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%du_other(I,j,k) * Inorm(k)) ; enddo endif if (associated(CS%u_accel_bt)) then - write(file,'(/,"dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%u_accel_bt(I,j,k) * Inorm(k)) ; enddo endif endif @@ -487,178 +487,178 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"v(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*vm(i,J,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"v(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*vm(i,J,k)) ; enddo if (prev_avail) then - write(file,'(/,"v(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo endif - write(file,'(/,"v(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_av(i,J,k)) ; enddo - write(file,'(/,"CFL v: ",$)') + write(file,'(/,"v(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_av(i,J,k)) ; enddo + write(file,'(/,"CFL v: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(vm(i,J,k)) * dt * G%dx_Cv(i,J) if (vm(i,J,k) < 0.0) then ; CFL = CFL * G%IareaT(i,j+1) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 v:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 v:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(vm(i,J,k)) * dt * G%IdyCv(i,J) ; enddo if (prev_avail) then - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(vm(i,J,k)-CS%v_prev(i,J,k))) ; enddo endif - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo if (associated(ADp%gradKEv)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEv(i,J,k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"vbv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vbv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(vm(i,J,k) - dt*ADp%dv_dt_visc(i,J,k)) ; enddo - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%dv_dt_visc(i,J,k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%dv_other(i,J,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(i,j,k)*dt) ; enddo + write(file,'(/,"a: ")', advance='no') + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(i,j,k)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(i,J,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(i,J,k) ; enddo endif write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%v_accel_bt)) then - write(file,'("dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'("dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%v_accel_bt(i,J,k)) ; enddo write(file,'(/)') endif - write(file,'("h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j,k) ; enddo - write(file,'(/,"h0-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j,k) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j+1,k) ; enddo - write(file,'(/,"h0+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j+1,k) ; enddo + write(file,'("h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j,k) ; enddo + write(file,'(/,"h0-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j,k) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j,k) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j+1,k) ; enddo + write(file,'(/,"h0+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j+1,k) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j+1,k) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j+1) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j+1,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j+1,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j+1,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j+1,k) ; enddo endif if (prev_avail) then - write(file,'(/,"u--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j,k) ; enddo - write(file,'(/,"u-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo - write(file,'(/,"u+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j,k) ; enddo - write(file,'(/,"u++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j+1,k) ; enddo - endif - - write(file,'(/,"uh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"u--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j,k) ; enddo + write(file,'(/,"u-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo + write(file,'(/,"u+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j,k) ; enddo + write(file,'(/,"u++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j+1,k) ; enddo + endif + + write(file,'(/,"uh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)) ; enddo - write(file,'(/," uhC--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"uh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)) ; enddo - write(file,'(/," uhC-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"uh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)) ; enddo - write(file,'(/," uhC+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"uh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)) ; enddo - write(file,'(/," uhC++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo endif @@ -672,44 +672,44 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / dv enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((vm(i,J,k)-CS%v_prev(i,J,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffv(i,J,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEv(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) * Inorm(k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%dv_dt_visc(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%dv_other(i,J,k) * Inorm(k)) ; enddo endif if (associated(CS%v_accel_bt)) then - write(file,'(/,"dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%v_accel_bt(i,J,k) * Inorm(k)) ; enddo endif endif diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index fda5a97d69..3b24a3871b 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -196,7 +196,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -386,7 +386,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -549,7 +549,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_nonsym(i,j) /= v_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_nonsym(i,j),v_comp(i,j)-v_nonsym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index a7cae98620..48097b40c4 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -848,13 +848,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif do m=1,nTr_stocks - write(stdout,'(" Total ",a,": ",ES24.16,X,a)') & + write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) if (Tr_minmax_avail(m)) then - write(stdout,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) - write(stdout,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Max:",ES24.16,1X,"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/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index d1a8102fc1..15db6abce9 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -2196,7 +2196,7 @@ subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) integer, intent(in) :: iounit !< Checksum logger IO unit if (is_root_pe()) & - write(iounit, '(A,1(A,I10,X),A)') fmsg, " c=", bc0, trim(mesg) + write(iounit, '(a,1(a,i10,1x),a)') fmsg, " c=", bc0, trim(mesg) end subroutine chk_sum_msg1 !> Write a message including checksums of non-shifted and diagonally shifted arrays diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 92d53330a7..1ed89ec47e 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3732,7 +3732,7 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string mesg = '"'//trim(field_name)//'" [Unused]' endif if (len(trim((comment)))>0) then - write(diag_CS%available_diag_doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment) + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) else write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) endif @@ -3754,7 +3754,7 @@ subroutine log_chksum_diag(docunit, description, chksum) character(len=*), intent(in) :: description !< Name of the diagnostic module integer, intent(in) :: chksum !< chksum of the diagnostic - write(docunit, '(a,x,i9.8)') description, chksum + write(docunit, '(a,1x,i9.8)') description, chksum flush(docunit) end subroutine log_chksum_diag diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 3d6e3e3f65..24ff07e7d0 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -311,8 +311,8 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (error==0.) then write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else - write(stdout,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif enddo endif @@ -350,8 +350,8 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (error==0.) then write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else - write(stdout,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif enddo endif diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index dc6c0a8996..00c42727e1 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -343,7 +343,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! 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), & + write(mesg,'(a,2(i5,1x,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 diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index de511688a9..5a125d5abd 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -66,7 +66,7 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then - write(lMesg(1:120),'(2(a,es12.4),a,i3,x,a)') & + write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') & 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 9df994448b..cc43ec19ea 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -200,7 +200,7 @@ subroutine write_cputime(day, n, CS, nmax, call_end) (CS%startup_cputime / CLOCKS_PER_SEC), num_pes() write(CS%fileCPU_ascii,*)" Day, Step number, CPU time, CPU time change" endif - write(CS%fileCPU_ascii,'(F12.3,", "I11,", ", F12.3,", ", F12.3)') & + write(CS%fileCPU_ascii,'(F12.3,", ",I11,", ",F12.3,", ",F12.3)') & reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & d_cputime / real(CLOCKS_PER_SEC) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 608a672a46..e1ecd45347 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2901,10 +2901,10 @@ end subroutine bilinear_shape_fn_grid subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction real, dimension(nsub,nsub,2,2,2,2), & intent(inout) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction ! this subroutine is a helper for interpolation of floatation condition ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 6b89a86b30..f711ef3f87 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -691,7 +691,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, 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 initialize_ALE_sponge." )') CS%fldno + &"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif ! get a unique time interp id for this field. If sponge data is on-grid, then setup diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 227e3ffb06..7296640560 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -343,8 +343,8 @@ 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 + real, dimension(n), intent(inout) :: x !< 1D array to be sorted ! local variables integer :: i, location @@ -1012,8 +1012,8 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans endif - 20 format(A,"=",i3,X,A,"=",i3) - 30 format(A,"=",f20.16,X,A,"=",f20.16) + 20 format(A,"=",i3,1X,A,"=",i3) + 30 format(A,"=",f20.16,1X,A,"=",f20.16) end function test_boundary_k_range diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 1a80829255..61715e044b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1364,7 +1364,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & if (CS%debug) then write(stdout,'(A,I2)') "Searching left layer ", kl_left - write(stdout,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,'(A,I2,1X,I2)') "Searching from right: ", kl_right, ki_right write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) @@ -1387,7 +1387,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & if (CS%debug) then write(stdout,'(A,I2)') "Searching right layer ", kl_right - write(stdout,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,'(A,I2,1X,I2)') "Searching from left: ", kl_left, ki_left write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) @@ -2651,9 +2651,9 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti if (test_fv_diff) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fv_diff) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2683,9 +2683,9 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue if (test_fvlsq_slope) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fvlsq_slope) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2713,10 +2713,10 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) if (test_ifndp) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_ifndp) then - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15),1x,a)') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15))') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2746,11 +2746,11 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1d = .true. - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,a)') & + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') & + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo @@ -2781,10 +2781,10 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1di = .true. - write(stdunit,'(a,i2,2(x,a,i5),x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' + write(stdunit,'(a,i2,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) + write(stdunit,'(a,i2,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) endif enddo endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 79fd4f3cbf..42e09b574e 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -326,6 +326,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & is, ie, js, je, k, G, GV, US, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on 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] @@ -337,7 +338,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & 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 integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on @@ -698,6 +698,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & is, ie, js, je, k, G, GV, US, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on 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] @@ -709,7 +710,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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 integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on From a5350219b34005dc68fa0838ed788de8bc71d207 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 6 Apr 2022 15:59:30 -0400 Subject: [PATCH 130/155] Mixed layer restrat statement function refactor Statement functions are obsolescent in the current language standard, and can be redefined as an internal function within a subprogram. This patch replaces the statement function `psi` (streamfunction) in `mixedlayer_restrat_general` as an explicit internal function. --- .../lateral/MOM_mixed_layer_restrat.F90 | 27 ++++++++++++------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index d8da752a1f..e1dff4f5bd 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -178,7 +178,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real :: aFac, bFac ! Nondimensional ratios [nondim] + real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] real :: zpa ! Fractional position within the mixed layer of the interface above a layer [nondim] @@ -190,15 +190,6 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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 - real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions [nondim] - ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) - !PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) ) - PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) * (1. + (5./21.)*(2.*z+1.)**2) ) - BOTTOP(z) = 0.5*(1.-SIGN(1.,z+0.5)) ! =0 for z>-0.5, =1 for z<-0.5 - XP(z) = max(0., min(1., (-z-0.5)*2./(1.+2.*CS%MLE_tail_dh) ) ) - 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 = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -557,6 +548,22 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) +contains + !> Stream function as a function of non-dimensional position within mixed-layer + real function psi(z) + real, intent(in) :: z !< Fractional mixed layer depth [nondim] + real :: psi1, bottop, xp, dd + + !psi1 = max(0., (1. - (2.*z + 1.)**2)) + psi1 = max(0., (1. - (2.*z + 1.)**2) * (1. + (5./21.)*(2.*z + 1.)**2)) + + xp = max(0., min(1., (-z - 0.5)*2. / (1. + 2.*CS%MLE_tail_dh))) + dd = (1. - 3.*(xp**2) + 2.*(xp**3))**(1. + 2.*CS%MLE_tail_dh) + bottop = 0.5*(1. - sign(1., z + 0.5)) ! =0 for z>-0.5, =1 for z<-0.5 + + psi = max(psi1, dd*bottop) ! Combines original psi1 with tail + end function psi + end subroutine mixedlayer_restrat_general From d2fb2d0edd955aeb4382c069df6764eeb5b0379e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 7 Apr 2022 09:08:59 -0400 Subject: [PATCH 131/155] MOM_random: Set mask with bits rather than integer The MOM_random generator used bit masks which were set with integer values. This is problematic for the sequence 0x8000 0000, because it must be set with a value of -2**31. In 4-byte integers, this is strictly not representable in Fortran, which requires symmetric signed domains for its variables. Since the upper bound is 2**31 - 1, the lower bound must be -2**31 + 1, which is larger than -2**31. Any value assigned to the 0x80000000 bit sequence is considered a noncompliant compiler extension. The current implementation seems to resolve this by using a kind=8 value (itself problematic, since 8-byte is not assured), but it still requires assigning this value to a 4-byte integer which cannot (strictly) represent the value. This patch averts the whole issue by explicitly setting the bits, and makes no reference to its integer value. It leaves the compiler to decide its interpretation. And since the variable is only used in bit operations, there is no ambiguity in behavior. Note that GCC 9 does not support BOZ conversion from z'80000000' to int, since it still expects BOZ literals to be within the bounds. This is why we use ibset() in place of a literal. Later GCC versions do not have this objection. --- src/framework/MOM_random.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index bef78a433a..cf649c32f7 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -7,6 +7,7 @@ module MOM_random use MOM_time_manager, only : time_type, set_date, get_date use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : int32 implicit none ; private @@ -20,11 +21,13 @@ module MOM_random 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) +integer, parameter :: & + blockSize = 624, & !< Size of the state vector + M = 397, & !< Pivot element in state vector + MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) + UMASK = ibset(0, 31), & !< 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) From 3c7bd19eecc9e1ce03e490d5d3e6b9e08cf73f9d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 7 Apr 2022 12:20:56 -0800 Subject: [PATCH 132/155] More cleaning up for issue #54 --- src/ALE/MOM_ALE.F90 | 2 +- src/core/MOM_barotropic.F90 | 8 +++--- src/core/MOM_open_boundary.F90 | 34 +++++++++++++++++-------- src/ocean_data_assim/MOM_oda_driver.F90 | 29 ++++++++++++++++++--- 4 files changed, 53 insertions(+), 20 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index df4f16409c..b632487cdf 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -719,7 +719,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal - real :: h_neglect, h_neglect_edge + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] nz = GV%ke diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e46bfc7c37..5bc52f9fe3 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1271,11 +1271,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & - CS%dx_Cv(i,J)*Htot_avg) ) * GV%Z_to_H + CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & - CS%dx_Cv(i,J)*Htot_avg) ) * GV%Z_to_H + CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) else CS%IDatv(i,J) = GV%Z_to_H / Htot_avg endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 47061f9447..9d87d0bc5d 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -310,6 +310,9 @@ module MOM_open_boundary real :: ramp_value !< If ramp is True, where we are on the ramp from !! zero to one [nondim]. type(time_type) :: ramp_start_time !< Time when model was started. + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -358,9 +361,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] character(len=128) :: inputdir - logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=64) :: remappingScheme + logical :: default_2018_answers ! This include declares and sets the variable "version". # include "version_variable.h" @@ -608,7 +611,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", OBC%answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) @@ -616,7 +619,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=OBC%answers_2018) endif ! OBC%number_of_segments > 0 @@ -3730,6 +3733,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] + real :: h_neglect, h_neglect_edge ! Small thicknesses [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3742,6 +3746,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) + if (.not. OBC%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -4008,21 +4020,21 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) 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,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) 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,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) endif enddo else @@ -4038,7 +4050,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) endif enddo endif @@ -4058,21 +4070,21 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) 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,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) 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,:), & GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) endif enddo else @@ -4088,7 +4100,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & - GV%H_subroundoff, GV%H_subroundoff) + h_neglect, h_neglect_edge) endif enddo endif diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index a4c59be85c..140cf3a4d6 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -134,6 +134,9 @@ module MOM_oda_driver_mod type(INC_CS) :: INC_CS !< A Structure containing integer file handles for bias adjustment integer :: id_inc_t !< A diagnostic handle for the temperature climatological adjustment integer :: id_inc_s !< A diagnostic handle for the salinity climatological adjustment + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. end type ODA_CS @@ -396,6 +399,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) integer :: isg, ieg, jsg, jeg, idg_offset, jdg_offset integer :: id logical :: used, symmetric + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] ! return if not time for analysis if (Time < CS%Time) return @@ -407,6 +411,14 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) call set_PElist(CS%filter_pelist) !call MOM_mesg('Setting prior') + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + ! computational domain for the analysis grid isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec ! array extents for the ensemble member @@ -415,9 +427,9 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) ! 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,:), GV%H_subroundoff, GV%H_subroundoff) + CS%nk, CS%h(i,j,:), T(i,j,:), h_neglect, h_neglect_edge) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:), GV%H_subroundoff, GV%H_subroundoff) + CS%nk, CS%h(i,j,:), S(i,j,:), h_neglect, h_neglect_edge) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -652,6 +664,7 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T !< The updated temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S !< The updated salinity [g kg-1] real :: missing_value + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (.not. associated(CS)) return if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return @@ -668,12 +681,20 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) S = S + CS%tv_bc%S endif + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec do j=jsc,jec; do i=isc,iec call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T(i,j,:), & - G%ke, h(i,j,:), T_inc(i,j,:), GV%H_subroundoff, GV%H_subroundoff) + G%ke, h(i,j,:), T_inc(i,j,:), h_neglect, h_neglect_edge) call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S(i,j,:), & - G%ke, h(i,j,:), S_inc(i,j,:), GV%H_subroundoff, GV%H_subroundoff) + G%ke, h(i,j,:), S_inc(i,j,:), h_neglect, h_neglect_edge) enddo; enddo From 9c22ff272e29fc147f3f7ff1738bad1e5f15ee42 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 7 Apr 2022 13:34:13 -0800 Subject: [PATCH 133/155] Taking out some unused OBC constants. --- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_open_boundary.F90 | 4 ---- src/initialization/MOM_state_initialization.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- src/user/DOME_initialization.F90 | 2 +- src/user/dyed_channel_initialization.F90 | 2 +- src/user/dyed_obcs_initialization.F90 | 2 +- src/user/supercritical_initialization.F90 | 2 +- src/user/user_initialization.F90 | 2 +- 9 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5bc52f9fe3..cd84c5f7b6 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -17,7 +17,7 @@ module MOM_barotropic use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, open_boundary_query +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, register_restart_pair diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9d87d0bc5d..6eaf685971 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -63,10 +63,6 @@ module MOM_open_boundary public initialize_segment_data integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary -integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary -integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed wall -integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary -integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4e8dd4f186..0167b7f220 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -20,7 +20,7 @@ module MOM_state_initialization use MOM_interface_heights, only : find_eta use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data -use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : OBC_NONE use MOM_open_boundary, only : open_boundary_query use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d384500c3d..a0c14162c4 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -13,7 +13,7 @@ module MOM_vert_friction use MOM_forcing_type, only : mech_forcing use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init use MOM_PointAccel, only : PointAccel_CS diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 248bf6c0f0..ed81f06b5b 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -10,7 +10,7 @@ module DOME_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_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_tracer_registry, only : tracer_name_lookup diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index ff98f16529..9fa672ceb6 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -8,7 +8,7 @@ module dyed_channel_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_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_open_boundary, only : OBC_registry_type, register_OBC use MOM_time_manager, only : time_type, time_type_to_real diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 0307d93d3d..15a06effd7 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -8,7 +8,7 @@ module dyed_obcs_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_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index b4ceb1905d..ddb38a9cdf 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -7,7 +7,7 @@ module supercritical_initialization 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_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE, OBC_segment_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_segment_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 diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index d59d271471..adccc40b81 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -8,7 +8,7 @@ module user_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_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N use MOM_open_boundary, only : OBC_DIRECTION_S use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS From 8d92579b2f8d0ed85ce0bbce9c4825d40f47ef59 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 7 Apr 2022 16:10:35 -0800 Subject: [PATCH 134/155] Deleted an unused function, made public OBC funcs. --- src/core/MOM_open_boundary.F90 | 87 ++-------------------------------- 1 file changed, 5 insertions(+), 82 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6eaf685971..ef53420cca 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -48,6 +48,9 @@ module MOM_open_boundary public open_boundary_test_extern_uv public open_boundary_test_extern_h public open_boundary_zero_normal_flow +public parse_segment_str +public parse_segment_manifest_str +public parse_segment_data_str public register_OBC, OBC_registry_init public register_file_OBC, file_OBC_end public segment_tracer_registry_init @@ -61,6 +64,8 @@ module MOM_open_boundary public rotate_OBC_config public rotate_OBC_init public initialize_segment_data +public flood_fill +public flood_fill2 integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary @@ -1694,88 +1699,6 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) end subroutine parse_for_tracer_reservoirs -!> 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 - - ! Process first word which will start with the fieldname - 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 - - 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 - !> Initialize open boundary control structure and do any necessary rescaling of OBC !! fields that have been read from a restart file. subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) From 1383961072e1446acd7ca8d7a3b3baeb16bd84ee Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 7 Apr 2022 21:21:39 -0800 Subject: [PATCH 135/155] It would be good to initialize CS%answers_2018. --- src/ocean_data_assim/MOM_oda_driver.F90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 140cf3a4d6..867d77a495 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -182,6 +182,7 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) logical :: reentrant_x, reentrant_y, tripolar_N, symmetric character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file + logical :: default_2018_answers if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -238,6 +239,14 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default="PPM_H4") + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false., do_not_log=.true.) + call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers, & + do_not_log=.true.) inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) From fd2060cda38dc2db2c83bbce6b9d4dba85c039c9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 10:37:59 -0400 Subject: [PATCH 136/155] +Add Hybgen regridding This commit adds the ability to use Hybgen regridding, derived from Hycom code. There are two new files, MOM_hybgen_regrid.F90 and MOM_hybgen_unmix.F90, which in turn add 15 new runtime parameters (with names like HYBGEN_...) to control the hybgen code. This new regridding option is specified via REGRIDDING_COORDINATE_MODE="HYBGEN", and this new option is listed in the MOM_parameter_doc files for cases that have USE_REGRIDDING=True. There is also a new publicly visible parameter, REGRIDDING_HYBGEN, in regrid_consts.F90. In addition, the new routine regridding_preadjust_reqs is provided in MOM_regridding to specify whether convective adjustment or hybgen_unmixing should be done before regridding. This is used along with the optional argument conv_adjust to regridding_main to move these pre-adjustment steps out of regridding_main. The unused routine ALE_build_grid was eliminated, and comments were added describing a few undocumented internal real variables. All answers are bitwise identical, but there are several new public interfaces and there will be new lines in the comments in some MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 103 +- src/ALE/MOM_hybgen_regrid.F90 | 983 ++++++++++++++++++ src/ALE/MOM_hybgen_unmix.F90 | 502 +++++++++ src/ALE/MOM_regridding.F90 | 97 +- src/ALE/regrid_consts.F90 | 5 + .../MOM_state_initialization.F90 | 39 +- 6 files changed, 1646 insertions(+), 83 deletions(-) create mode 100644 src/ALE/MOM_hybgen_regrid.F90 create mode 100644 src/ALE/MOM_hybgen_unmix.F90 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index fa195d57eb..97303aa100 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -20,6 +20,8 @@ module MOM_ALE use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_hybgen_unmix, only : hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix, hybgen_unmix_CS +use MOM_hybgen_regrid, only : hybgen_regrid_CS use MOM_file_parser, only : get_param, param_file_type, log_param use MOM_interface_heights,only : find_eta use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W @@ -27,6 +29,7 @@ module MOM_ALE use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution use MOM_regridding, only : inflate_vanished_layers_old +use MOM_regridding, only : regridding_preadjust_reqs, convective_adjustment use MOM_regridding, only : set_target_densities_from_GV, set_target_densities use MOM_regridding, only : regriddingCoordinateModeDoc, DEFAULT_COORDINATE_MODE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme @@ -73,6 +76,11 @@ module MOM_ALE type(remapping_CS) :: remapCS !< Remapping parameters and work arrays type(remapping_CS) :: vel_remapCS !< Remapping parameters for velocities and work arrays + type(hybgen_unmix_CS), pointer :: hybgen_unmixCS => NULL() !< Parameters for hybgen remapping + + logical :: use_hybgen_unmix !< If true, use the hybgen unmixing code before regridding + logical :: do_conv_adj !< If true, do convective adjustment before regridding + integer :: nk !< Used only for queries, not directly by this module real :: BBL_h_vel_mask !< The thickness of a bottom boundary layer within which velocities in !! thin layers are zeroed out after remapping, following practice with @@ -119,7 +127,6 @@ module MOM_ALE public ALE_main_offline public ALE_offline_inputs public ALE_offline_tracer_final -public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar public ALE_PLM_edge_values @@ -165,6 +172,8 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: force_bounds_in_subcell logical :: local_logical logical :: remap_boundary_extrap + type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding + ! for sharing parameters. if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -184,6 +193,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) + call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, hybgen_CS=hybgen_regridCS) ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & @@ -277,6 +287,9 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "to avoid such filtering altogether.", & default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) + if (CS%use_hybgen_unmix) & + call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + call get_param(param_file, "MOM", "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) @@ -350,6 +363,7 @@ subroutine ALE_end(CS) ! Deallocate memory used for the regridding call end_remapping( CS%remapCS ) + if (CS%use_hybgen_unmix) call end_hybgen_unmix( CS%hybgen_unmixCS ) call end_regridding( CS%regridCS ) deallocate(CS) @@ -379,9 +393,9 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) !< If true, PCM remapping should be used in a cell. - integer :: nk, i, j, k, isc, iec, jsc, jec, ntr + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main(), MOM_ALE.F90") @@ -401,10 +415,19 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) endif dzRegrid(:,:,:) = 0.0 + ! If necessary, do some preparatory work to clean up the model state before regridding. + + ! This adjusts the input thicknesses prior to remapping, based on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! 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. call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & - frac_shelf_h, PCM_cell=PCM_cell) + frac_shelf_h, conv_adjust=.false., PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) @@ -459,9 +482,9 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main_offline(), MOM_ALE.F90") @@ -470,9 +493,16 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) endif dzRegrid(:,:,:) = 0.0 + ! This adjusts the input state prior to remapping, depending on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! 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. - 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, conv_adjust=.false. ) call check_grid( G, GV, h, 0. ) @@ -519,7 +549,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) real, dimension(SZK_(GV)) :: h_dest ! Destination grid thicknesses at velocity points [H ~> m or kg m-2] real, dimension(SZK_(GV)) :: temp_vec ! Transports on the destination grid [H L2 ~> m3 or kg] - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke dzRegrid(:,:,:) = 0.0 h_new(:,:,:) = 0.0 @@ -595,13 +625,18 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid !< The change in grid interface positions real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new !< Regridded target thicknesses - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_offline_tracer_final(), MOM_ALE.F90") ! Need to make sure that h_target is consistent with the current offline ALE confiuration - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid ) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_target, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h_target, 0. ) @@ -651,52 +686,17 @@ subroutine check_grid( G, GV, h, threshold ) end subroutine check_grid -!### This routine does not appear to be used. -!> Generates new grid -subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(regridding_CS), intent(in) :: regridCS !< Regridding parameters and options - type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variable structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in):: frac_shelf_h !< Fractional ice shelf coverage [nondim] - ! Local variables - integer :: nk, i, j, k - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! The new grid thicknesses - logical :: show_call_tree - - show_call_tree = .false. - if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("ALE_build_grid(), MOM_ALE.F90") - - ! 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. - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(G,h,h_new) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) h(i,j,:) = h_new(i,j,:) - enddo ; enddo - - if (show_call_tree) call callTree_leave("ALE_build_grid()") -end subroutine ALE_build_grid !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) - integer, intent(in) :: n !< Number of times to regrid + integer, intent(in) :: n_itt !< Number of times to regrid 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)), & @@ -711,7 +711,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg !! routine (and expect diagnostics to work) ! Local variables - integer :: i, j, k, nz + integer :: i, j, itt, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses @@ -744,11 +744,12 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg if (present(dt)) & call ALE_update_regrid_weights(dt, CS) - do k = 1, n + do itt = 1, n_itt call do_group_pass(pass_T_S_h, G%domain) ! generate new grid - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface, conv_adjust=.false.) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 new file mode 100644 index 0000000000..783820829f --- /dev/null +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -0,0 +1,983 @@ +!> This module contains the hybgen regridding routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_regrid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE +use MOM_string_functions, only : slasher +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_regrid_CS ; private + + real :: min_thickness !< Minimum thickness allowed for layers [H ~> m or kg m-2] + + integer :: nk !< Number of layers on the target grid + + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure + + !> Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + real :: hybiso + !> Number of sigma levels used by HYBGEN + integer :: nsigma + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Fractional relaxation within a regridding step [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to values in m + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to values in kg m-3 + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: thkbot !< Thickness of a bottom boundary layer, within which hybgen does + !! something different. [H ~> m or kg m-2] + + !> Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real :: topiso_const + ! real, dimension(:,:), allocatable :: topiso + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:) :: target_density + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2] + +end type hybgen_regrid_CS + + +public hybgen_regrid, init_hybgen_regrid, end_hybgen_regrid +public hybgen_column_init, get_hybgen_regrid_params, write_Hybgen_coord_file + +contains + +!> Initialise a hybgen_regrid_CS control structure and store its parameters +subroutine init_hybgen_regrid(CS, GV, US, param_file) + type(hybgen_regrid_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file + + character(len=40) :: mdl = "MOM_hybgen_regrid" ! This module's name. + real :: hybrlx ! The number of remappings over which to move toward the target coordinate [timesteps] + character(len=40) :: dp0_coord_var, ds0_coord_var, rho_coord_var + character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + logical :: use_coord_file + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_regrid: CS already associated!") + allocate(CS) + + CS%nk = GV%ke + + allocate(CS%target_density(CS%nk)) + allocate(CS%dp0k(CS%nk), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(CS%nk), source=0.0) ! minimum shallow z-layer separation + + do k=1,CS%nk ; CS%target_density(k) = GV%Rlay(k) ; enddo + + call get_param(param_file, mdl, "P_REF", CS%ref_pressure, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + + call get_param(param_file, mdl, "HYBGEN_MIN_THICKNESS", CS%min_thickness, & + "The minimum layer thickness allowed when regridding with Hybgen.", & + units="m", default=0.0, scale=GV%m_to_H ) + + call get_param(param_file, mdl, "HYBGEN_N_SIGMA", CS%nsigma, & + "The number of sigma-coordinate (terrain-following) layers with Hybgen regridding.", & + default=0) + call get_param(param_file, mdl, "HYBGEN_COORD_FILE", coord_file, & + "The file from which the Hybgen profile is read, or blank to use a list of "//& + "real input parameters from the MOM_input file.", default="") + + use_coord_file = (len_trim(coord_file) > 0) + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_PR0FILE", CS%dp0k, & + "The layerwise list of deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_PR0FILE", CS%ds0k, & + "The layerwise list of shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + + if (use_coord_file) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/HYBGEN_COORD_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_file: Unable to open "//trim(filename)) + + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_VAR", dp0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + default="dp0") + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_VAR", ds0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + default="ds0") + call get_param(param_file, mdl, "HYBGEN_TGT_DENSITY_VAR", rho_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the Hybgen "//& + "target layer densities, or blank to reuse the values in GV%Rlay.", & + default="") + + call MOM_read_data(filename, dp0_coord_var, CS%dp0k, scale=GV%m_to_H) + + call MOM_read_data(filename, ds0_coord_var, CS%ds0k, scale=GV%m_to_H) + + if (len_trim(rho_coord_var) > 0) & + call MOM_read_data(filename, rho_coord_var, CS%target_density, scale=US%kg_m3_to_R) + endif + + call get_param(param_file, mdl, "HYBGEN_ISOPYCNAL_DZ_MIN", CS%dp00i, & + "The Hybgen deep isopycnal spacing minimum thickness (dp00i in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_MIN_ISO_DEPTH", CS%topiso_const, & + "The Hybgen shallowest depth for isopycnal layers (isotop in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_RELAX_PERIOD", hybrlx, & + "The Hybgen coordinate relaxation period in timesteps, or 1 to move to "//& + "the new target coordinates in a single step. This must be >= 1.", & + units="timesteps", default=1.0) + if (hybrlx < 1.0) call MOM_error(FATAL, "init_hybgen_regrid: HYBGEN_RELAX_PERIOD must be at least 1.") + CS%qhybrlx = 1.0 / hybrlx + call get_param(param_file, mdl, "HYBGEN_BBL_THICKNESS", CS%thkbot, & + "A bottom boundary layer thickness within which Hybgen is able to move "//& + "overlying layers upward to match a target density.", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & + "A tolerance between the layer densities and their target, within which "//& + "Hybgen determines that remapping uses PCM for a layer.", & + units="kg m-3", default=0.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "HYBGEN_REMAP_MIN_ZSTAR_DILATE", CS%min_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=0.5) + call get_param(param_file, mdl, "HYBGEN_REMAP_MAX_ZSTAR_DILATE", CS%max_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=2.0) + + CS%onem = 1.0 * GV%m_to_H + + do k=1,CS%nk ; CS%dp0k(k) = max(CS%dp0k(k), CS%min_thickness) ; enddo + CS%dp00i = max(CS%dp00i, CS%min_thickness) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + + CS%coord_scale = GV%H_to_m + CS%Rho_coord_scale = US%R_to_kg_m3 + +end subroutine init_hybgen_regrid + +!> Writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model. +subroutine write_Hybgen_coord_file(GV, CS, filepath) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(hybgen_regrid_CS), intent(in) :: CS !< Control structure for this module + character(len=*), intent(in) :: filepath !< The full path to the file to write + ! Local variables + type(vardesc) :: vars(3) + type(fieldtype) :: fields(3) + type(file_type) :: IO_handle ! The I/O handle of the fileset + + vars(1) = var_desc("dp0", "meter", "Deep z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(2) = var_desc("ds0", "meter", "Shallow z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(3) = var_desc("Rho_tgt", "kg m-3", "Target coordinate potential densities for Hybgen", '1', 'L', '1') + call create_file(IO_handle, trim(filepath), vars, 3, fields, SINGLE_FILE, GV=GV) + + call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) + + call close_file(IO_handle) + +end subroutine write_Hybgen_coord_file + +!> This subroutine deallocates memory in the control structure for the hybgen module +subroutine end_hybgen_regrid(CS) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_regrid + +!> This subroutine can be used to retrieve the parameters for the hybgen regrid module +subroutine get_hybgen_regrid_params(CS, nk, ref_pressure, hybiso, nsigma, dp00i, qhybrlx, & + dp0k, ds0k, dpns, dsns, min_dilate, max_dilate, & + thkbot, topiso_const, target_density) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate regridding control structure + integer, optional, intent(out) :: nk !< Number of layers on the target grid + real, optional, intent(out) :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, optional, intent(out) :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + integer, optional, intent(out) :: nsigma !< Number of sigma levels used by HYBGEN + real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness (m) + real, optional, intent(out) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, optional, intent(out) :: dp0k(:) !< minimum deep z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: ds0k(:) !< minimum shallow z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: min_dilate !< The minimum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when wetting occurs. + real, optional, intent(out) :: max_dilate !< The maximum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when drying occurs. + real, optional, intent(out) :: thkbot !< Thickness of a bottom boundary layer, within which + !! hybgen does something different. [H ~> m or kg m-2] + real, optional, intent(out) :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + real, optional, intent(out) :: target_density(:) !< Nominal density of interfaces [R ~> kg m-3] + + if (.not. associated(CS)) call MOM_error(FATAL, "get_hybgen_params: CS not associated") + + if (present(nk)) nk = CS%nk + if (present(ref_pressure)) ref_pressure = CS%ref_pressure + if (present(hybiso)) hybiso = CS%hybiso + if (present(nsigma)) nsigma = CS%nsigma + if (present(dp00i)) dp00i = CS%dp00i + if (present(qhybrlx)) qhybrlx = CS%qhybrlx + if (present(dp0k)) then + if (size(dp0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The dp0k argument is not allocated with enough space.") + dp0k(1:CS%nk) = CS%dp0k(1:CS%nk) + endif + if (present(ds0k)) then + if (size(ds0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The ds0k argument is not allocated with enough space.") + ds0k(1:CS%nk) = CS%ds0k(1:CS%nk) + endif + if (present(dpns)) dpns = CS%dpns + if (present(dsns)) dsns = CS%dsns + if (present(min_dilate)) min_dilate = CS%min_dilate + if (present(max_dilate)) max_dilate = CS%max_dilate + if (present(thkbot)) thkbot = CS%thkbot + if (present(topiso_const)) topiso_const = CS%topiso_const + if (present(target_density)) then + if (size(target_density) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The target_density argument is not allocated with enough space.") + target_density(1:CS%nk) = CS%target_density(1:CS%nk) + endif + +end subroutine get_hybgen_regrid_params + + +!> Modify the input grid to give a new vertical grid based on the HYCOM hybgen code. +subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & + intent(inout) :: dzInterface !< The change in height of each interface, + !! using a sign convention opposite to the change + !! in pressure [H ~> m or kg m-2] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: PCM_cell !< If true, PCM remapping should be used in a cell. + !! This is effectively intent out, but values in wide + !! halo regions and land points are reused. + + ! --- ------------------------------------- + ! --- hybrid grid generator from HYCOM + ! --- ------------------------------------- + + ! These notes on the parameters for the hybrid grid generator are inhereted from the + ! Hycom source code for these algorithms. + ! + ! From blkdat.input (units may have changed from m to pressure): + ! + ! --- 'nsigma' = number of sigma levels + ! --- 'dp0k ' = layer k deep z-level spacing minimum thickness (m) + ! --- k=1,nk + ! --- 'ds0k ' = layer k shallow z-level spacing minimum thickness (m) + ! --- k=1,nsigma + ! --- 'dp00i' = deep isopycnal spacing minimum thickness (m) + ! --- 'isotop' = shallowest depth for isopycnal layers (m) + ! now in topiso(:,:) + ! --- 'sigma ' = isopycnal layer target densities (sigma units) + ! --- now in theta(:,:,1:nk) + ! + ! --- the above specifies a vertical coord. that is isopycnal or: + ! --- near surface z in deep water, based on dp0k + ! --- near surface z in shallow water, based on ds0k and nsigma + ! --- terrain-following between them, based on ds0k and nsigma + ! + ! --- terrain following starts at depth dpns=sum(dp0k(k),k=1,nsigma) and + ! --- ends at depth dsns=sum(ds0k(k),k=1,nsigma), and the depth of the + ! --- k-th layer interface varies linearly with total depth between + ! --- these two reference depths, i.e. a z-sigma-z fixed coordinate. + ! + ! --- near the surface (i.e. shallower than isotop), layers are always + ! --- fixed depth (z or sigma). + ! -- layer 1 is always fixed, so isotop=0.0 is not realizable. + ! --- near surface layers can also be forced to be fixed depth + ! --- by setting target densities (sigma(k)) very small. + ! + ! --- away from the surface, the minimum layer thickness is dp00i. + ! + ! --- for fixed depth targets to be: + ! --- z-only set nsigma=0, + ! --- sigma-z (shallow-deep) use a very small ds0k(:), + ! --- sigma-only set nsigma=nk, dp0k large, and ds0k small. + + ! These arrays work with the input column + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: temp_in(GV%ke) ! A column of input potential temperatures [degC] + real :: saln_in(GV%ke) ! A column of input layer salinities [ppt] + real :: Rcv_in(GV%ke) ! An input column of coordinate potential density [R ~> kg m-3] + real :: dp_in(GV%ke) ! The input column of layer thicknesses [H ~> m or kg m-2] + logical :: PCM_lay(GV%ke) ! If true for a layer, use PCM remapping for that layer + + ! These arrays are on the target grid. + real :: Rcv_tgt(CS%nk) ! Target potential density [R ~> kg m-3] + real :: Rcv(CS%nk) ! Initial values of coordinate potential density on the target grid [R ~> kg m-3] + real :: h_col(CS%nk) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: dz_int(CS%nk+1) ! The change in interface height due to remapping [H ~> m or kg m-2] + real :: Rcv_integral ! Integrated coordinate potential density in a layer [R H ~> kg m-2 or kg2 m-5] + + real :: qhrlx(CS%nk+1) ! Fractional relaxation within a timestep (between 0 and 1) [nondim] + real :: dp0ij(CS%nk) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(CS%nk+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + integer :: fixlay ! Deepest fixed coordinate layer + integer, dimension(0:CS%nk) :: k_end ! The index of the deepest source layer that contributes to + ! each target layer, in the unusual case where the the input grid is + ! larger than the new grid. This situation only occurs during certain + ! types of initialization or when generating output diagnostics. + integer :: i, j, k, nk, m, k2, nk_in + + nk = CS%nk + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + ! Store one-dimensional arrays of thicknesses for the 'old' vertical grid before regridding + h_tot = 0.0 + do K=1,GV%ke + temp_in(k) = tv%T(i,j,k) + saln_in(k) = tv%S(i,j,k) + dp_in(k) = dp(i,j,k) + h_tot = h_tot + dp_in(k) + enddo + + ! This sets the input column's coordinate potential density from T and S. + call calculate_density(temp_in, saln_in, p_col, Rcv_in, tv%eqn_of_state) + + ! Set the initial properties on the new grid from the old grid. + nk_in = GV%ke + if (GV%ke > CS%nk) then ; do k=GV%ke,CS%nk+1,-1 + ! Remove any excess massless layers from the bottom of the input column. + if (dp_in(k) > 0.0) exit + nk_in = k-1 + enddo ; endif + + if (CS%nk >= nk_in) then + ! Simply copy over the common layers. This is the usual case. + do k=1,min(CS%nk,GV%ke) + h_col(k) = dp_in(k) + Rcv(k) = Rcv_in(k) + enddo + if (CS%nk > GV%ke) then + ! Pad out the input column with additional massless layers with the bottom properties. + ! This case only occurs during initialization or perhaps when writing diagnostics. + do k=GV%ke+1,CS%nk + Rcv(k) = Rcv_in(GV%ke) + h_col(k) = 0.0 + enddo + endif + else ! (CS%nk < nk_in) + ! The input column has more data than the output. For now, combine layers to + ! make them the same size, but there may be better approaches that should be taken. + ! This case only occurs during initialization or perhaps when writing diagnostics. + ! This case was not handled by the original Hycom code in hybgen.F90. + do k=0,CS%nk ; k_end(k) = (k * nk_in) / CS%nk ; enddo + do k=1,CS%nk + h_col(k) = 0.0 ; Rcv_integral = 0.0 + do k2=k_end(k-1) + 1,k_end(k) + h_col(k) = h_col(k) + dp_in(k2) + Rcv_integral = Rcv_integral + dp_in(k2)*Rcv_in(k2) + enddo + if (h_col(k) > GV%H_subroundoff) then + ! Take the volume-weighted average properties. + Rcv(k) = Rcv_integral / h_col(k) + else ! Take the properties of the topmost source layer that contributes. + Rcv(k) = Rcv_in(k_end(k-1) + 1) + endif + enddo + endif + + ! Set the target densities for the new layers. + do k=1,CS%nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + enddo + + ! The following block of code is used to trigger z* stretching of the targets heights. + nominalDepth = (G%bathyT(i,j) + G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Determine whether to require the use of PCM remapping from each source layer. + do k=1,GV%ke + if (CS%hybiso > 0.0) then + ! --- thin or isopycnal source layers are remapped with PCM. + PCM_lay(k) = (k > fixlay) .and. (abs(Rcv(k) - Rcv_tgt(k)) < CS%hybiso) + else ! hybiso==0.0, so purely isopycnal layers use PCM + PCM_lay(k) = .false. + endif ! hybiso + enddo !k + + ! Determine the new layer thicknesses. + call hybgen_column_regrid(CS, nk, CS%thkbot, CS%onem, & + 1.0e-11*US%kg_m3_to_R, Rcv_tgt, fixlay, qhrlx, dp0ij, & + dp0cum, Rcv, h_col, dz_int) + + ! Store the output from hybgenaij_regrid in 3-d arrays. + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = PCM_lay(k) + enddo ; endif + + do K=1,nk+1 + ! Note that dzInterface uses the opposite sign convention from the change in p. + dzInterface(i,j,K) = -dz_int(K) + enddo + + else + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = .false. + enddo ; endif + do k=1,CS%nk+1 ; dzInterface(i,j,k) = 0.0 ; enddo + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_regrid + +!> Initialize some of the variables that are used for regridding or unmixing, including the +!! stretched contraits on where the new interfaces can be. +subroutine hybgen_column_init(nk, nsigma, dp0k, ds0k, dp00i, topiso_i_j, & + qhybrlx, dpns, dsns, h_tot, dilate, h_col, & + fixlay, qhrlx, dp0ij, dp0cum) + integer, intent(in) :: nk !< The number of layers in the new grid + integer, intent(in) :: nsigma !< The number of sigma levels + real, intent(in) :: dp0k(nk) !< Layer deep z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: ds0k(nsigma) !< Layer shallow z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real, intent(in) :: topiso_i_j !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real, intent(in) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, intent(in) :: h_tot !< The sum of the initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dilate !< A factor by which to dilate the target positions + !! from z to z* [nondim] + real, intent(in) :: h_col(nk) !< Initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dpns !< Vertical sum of dp0k [H ~> m or kg m-2] + real, intent(in) :: dsns !< Vertical sum of ds0k [H ~> m or kg m-2] + integer, intent(out) :: fixlay !< Deepest fixed coordinate layer + real, intent(out) :: qhrlx(nk+1) !< Fractional relaxation within a timestep (between 0 and 1) [nondim] + real, intent(out) :: dp0ij(nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(out) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + + ! --- -------------------------------------------------------------- + ! --- hybrid grid generator, single column - initialization. + ! --- -------------------------------------------------------------- + + ! Local variables + character(len=256) :: mesg ! A string for output messages + real :: hybrlx ! The relaxation rate in the hybrid region [timestep-1]? + real :: qdep ! Total water column thickness as a fraction of dp0k (vs ds0k) [nondim] + real :: q ! A portion of the thickness that contributes to the new cell [H ~> m or kg m-2] + real :: p_int(nk+1) ! Interface depths [H ~> m or kg m-2] + integer :: k, fixall + + ! --- dpns = sum(dp0k(k),k=1,nsigma) + ! --- dsns = sum(ds0k(k),k=1,nsigma) + ! --- terrain following starts (on the deep side) at depth dpns and ends (on the + ! --- shallow side) at depth dsns and the depth of the k-th layer interface varies + ! --- linearly with total depth between these two reference depths. + if ((h_tot >= dilate * dpns) .or. (dpns <= dsns)) then + qdep = 1.0 ! Not terrain following - this column is too thick or terrain following is disabled. + elseif (h_tot <= dilate * dsns) then + qdep = 0.0 ! Not terrain following - this column is too thin + else + qdep = (h_tot - dilate * dsns) / (dilate * (dpns - dsns)) + endif + + if (qdep < 1.0) then + ! Terrain following or shallow fixed coordinates, qhrlx=1 and ignore dp00 + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 + dp0ij( 1) = dilate * (qdep*dp0k(1) + (1.0-qdep)*ds0k(1)) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + qhrlx( k+1) = 1.0 + dp0ij( k) = dilate * (qdep*dp0k(k) + (1.0-qdep)*ds0k(k)) + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int( k+1) = p_int(k) + h_col(k) + enddo !k + else + ! Not terrain following + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 !no relaxation in top layer + dp0ij( 1) = dilate * dp0k(1) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 !no relaxation in top layer + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + if ((dp0k(k) <= dp00i) .or. (dilate * dp0k(k) >= p_int(k) - dp0cum(k))) then + ! This layer is in fixed surface coordinates. + dp0ij(k) = dp0k(k) + qhrlx(k+1) = 1.0 + else + q = dp0k(k) * (dilate * dp0k(k) / ( p_int(k) - dp0cum(k)) ) ! A fraction between 0 and 1 of dp0 to use here. + if (dp00i >= q) then + ! This layer is much deeper than the fixed surface coordinates. + dp0ij(k) = dp00i + qhrlx(k+1) = qhybrlx + else + ! This layer spans the margins of the fixed surface coordinates. + ! In this case dp00i < q < dp0k. + dp0ij(k) = dilate * q + qhrlx(k+1) = qhybrlx * (dp0k(k) - dp00i) / & + ((dp0k(k) - q) + (q - dp00i)*qhybrlx) ! 1 at dp0k, qhybrlx at dp00i + endif + + ! The old equivalent code is: + ! hybrlx = 1.0 / qhybrlx + ! q = max( dp00i, dp0k(k) * (dp0k(k) / max(dp0k( k), p_int(k) - dp0cum(k)) ) ) + ! qts = 1.0 - (q-dp00i) / (dp0k(k) - dp00i) !0 at q = dp0k, 1 at q=dp00i + ! qhrlx( k+1) = 1.0 / (1.0 + qts*(hybrlx-1.0)) !1 at dp0k, qhybrlx at dp00i + endif + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int(k+1) = p_int(k) + h_col(k) + enddo !k + endif !qdep<1:else + + ! Identify the current fixed coordinate layers + fixlay = 1 !layer 1 always fixed + do k=2,nk + if (dp0cum(k) >= dilate * topiso_i_j) then + exit !layers k to nk might be isopycnal + endif + ! Top of layer is above topiso, i.e. always fixed coordinate layer + qhrlx(k+1) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + + fixall = fixlay + do k=fixall+1,nk + if (p_int(k+1) > dp0cum(k+1) + 0.1*dp0ij(k)) then + if ( (fixlay > fixall) .and. (p_int(k) > dp0cum(k)) ) then + ! --- The previous layer should remain fixed. + fixlay = fixlay-1 + endif + exit !layers k to nk might be isopycnal + endif + ! Sometimes fixed coordinate layer + qhrlx(k) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + +end subroutine hybgen_column_init + +!> The cushion function from Bleck & Benjamin, 1992, which returns a smoothly varying +!! but limited value that goes between dp0 and delp +real function cushn(delp, dp0) + real, intent(in) :: delp ! A thickness change [H ~> m or kg m-2] + real, intent(in) :: dp0 ! A non-negative reference thickness [H ~> m or kg m-2] + + real :: qq ! A limited ratio of delp/dp0 [nondim] + + ! These are the nondimensional parameters that define the cushion function. + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] + ! These are derivative nondimensional parameters. + ! real, parameter :: cusha = qqmn**2 * (qqmx-1.0) / (qqmx-qqmn)**2 + ! real, parameter :: I_qqmn = 1.0 / qqmn + real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 + real, parameter :: I_qqmx = 1.0 / qqmx + + ! --- if delp >= qqmx*dp0 >> dp0, cushn returns delp. + ! --- if delp <= qqmn*dp0 << -dp0, cushn returns dp0. + + ! This is the original version from Hycom. + ! qq = max(qqmn, min(qqmx, delp/dp0)) + ! cushn = dp0 * (1.0 + cusha * (1.0-I_qqmn*qq)**2) * max(1.0, delp/(dp0*qqmx)) + + ! This is mathematically equivalent, has one fewer divide, and works as intended even if dp0 = 0. + if (delp >= qqmx*dp0) then + cushn = delp + elseif (delp < qqmn*dp0) then + cushn = max(dp0, delp * I_qqmx) + else + cushn = max(dp0, delp * I_qqmx) * (1.0 + qq_scale * ((delp / dp0) - qqmn)**2) + endif + +end function cushn + +!> Create a new grid for a column of water using the Hybgen algorithm. +subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & + fixlay, qhrlx, dp0ij, dp0cum, Rcv, h_in, dp_int) + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen regridding control structure + integer, intent(in) :: nk !< number of layers + real, intent(in) :: thkbot !< thickness of bottom boundary layer [H ~> m or kg m-2] + real, intent(in) :: onem !< one m in pressure units [H ~> m or kg m-2] + real, intent(in) :: epsil !< small nonzero density to prevent division by zero [R ~> kg m-3] + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx( nk+1) !< relaxation coefficient per timestep [nondim] + real, intent(in) :: dp0ij( nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(in) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + real, intent(in) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + real, intent(in) :: h_in(nk) !< Layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: dp_int(nk+1) !< The change in interface positions [H ~> m or kg m-2] + + ! --- ------------------------------------------------------ + ! --- hybrid grid generator, single column - regrid. + ! --- ------------------------------------------------------ + + ! Local variables + real :: p_new ! A new interface position [H ~> m or kg m-2] + real :: pres_in(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: p_int(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: h_col(nk) ! Updated layer thicknesses [H ~> m or kg m-2] + real :: q_frac ! A fraction of a layer to entrain [nondim] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2] + real :: h_hat3 ! Thickness movement upward across the interface between layers k-2 and k-3 [H ~> m or kg m-2] + real :: h_hat2 ! Thickness movement upward across the interface between layers k-1 and k-2 [H ~> m or kg m-2] + real :: h_hat ! Thickness movement upward across the interface between layers k and k-1 [H ~> m or kg m-2] + real :: h_hat0 ! A first guess at thickness movement upward across the interface + ! between layers k and k-1 [H ~> m or kg m-2] + real :: dh_cor ! Thickness changes [H ~> m or kg m-2] + real :: h1_tgt ! A target thickness for the top layer [H ~> m or kg m-2] + real :: tenm ! ten m in pressure units [H ~> m or kg m-2] + real :: onemm ! one mm in pressure units [H ~> m or kg m-2] + logical :: trap_errors + integer :: k + character(len=256) :: mesg ! A string for output messages + + ! This line needs to be consistent with the parameters set in cushn(). + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn + + !### These hard-coded parameters should be changed to run-time variables. + tenm = 10.0*onem + onemm = 0.001*onem + + trap_errors = .true. + + do K=1,nk+1 ; dp_int(K) = 0.0 ; enddo + + p_int(1) = 0.0 + do k=1,nk + h_col(k) = max(h_in(k), 0.0) + p_int(K+1) = p_int(K) + h_col(k) + enddo + h_min = min( CS%min_thickness, p_int(nk+1)/real(CS%nk) ) + + if (trap_errors) then + do K=1,nk+1 ; pres_in(K) = p_int(K) ; enddo + endif + + ! Try to restore isopycnic conditions by moving layer interfaces + ! qhrlx(k) are relaxation amounts per timestep. + + ! Maintain prescribed thickness in layer k <= fixlay + ! There may be massless layers at the bottom, so work upwards. + do k=min(nk-1,fixlay),1,-1 + p_new = min(dp0cum(k+1), p_int(nk+1) - (nk-k)*h_min) ! This could be positive or negative. + dh_cor = p_new - p_int(K+1) + if (k= h_min) exit ! usually get here quickly + dh_cor = h_min - h_col(k) ! This is positive. + h_col(k) = h_min ! = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(fixlay+1) + enddo + if (h_col(nk) < h_min) then ! This should be uncommon, and should only arise at the level of roundoff. + do k=nk,2,-1 + if (h_col(k) >= h_min) exit + dh_cor = h_col(k) - h_min ! dh_cor is negative. + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_min ! = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + enddo + endif + + ! Remap the non-fixed layers. + + ! In the Hycom version, this loop was fused the loop correcting water that is + ! too light, and it ran down the water column, but if there are a set of layers + ! that are very dense, that structure can lead to all of the water being remapped + ! into a single thick layer. Splitting the loops and running the loop upwards + ! (as is done here avoids that catastrophic problem for layers that are far from + ! their targets. However, this code is still prone to a thin-thick-thin null mode. + do k=nk,fixlay+2,-1 + ! This is how the Hycom code would do this loop: do k=fixlay+1,nk ; if (k>fixlay+1) then + + if ((Rcv(k) > Rcv_tgt(k) + epsil)) then + ! Water in layer k is too dense, so try to dilute with water from layer k-1 + ! Do not move interface if k = fixlay + 1 + + if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & + (p_int(k) <= dp0cum(k) + onem) .or. & + (h_col(k) <= h_col(k-1))) then + ! If layer k-1 is too light, there is a conflict in the direction the + ! inteface between them should move, so thicken the thinner of the two. + + if ((Rcv_tgt(k) - Rcv(k-1)) <= epsil) then + ! layer k-1 is far too dense, take the entire layer + ! If this code is working downward and this branch is repeated in a series + ! of successive layers, it can accumulate into a very thick homogenous layers. + h_hat0 = 0.0 ! This line was not in the Hycom version of hybgen.F90. + h_hat = dp0ij(k-1) - h_col(k-1) + else + ! Entrain enough from the layer above to bring layer k to its target density. + q_frac = (Rcv_tgt(k) - Rcv(k)) / (Rcv_tgt(k) - Rcv(k-1)) ! -1 <= q_frac < 0 + h_hat0 = q_frac*h_col(k) ! -h_col(k-1) <= h_hat0 < 0 + if (k == fixlay+2) then + ! Treat layer k-1 as fixed. + h_hat = max(h_hat0, dp0ij(k-1) - h_col(k-1)) + else + ! Maintain the minimum thickess of layer k-1. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !fixlay+2:else + endif + ! h_hat is usually negative, so this check may be unnecessary if the values of + ! dp0ij are limited to not be below the seafloor? + h_hat = min(h_hat, p_int(nk+1) - p_int(k)) + + ! If isopycnic conditions cannot be achieved because of a blocking + ! layer (thinner than its minimum thickness) in the interior ocean, + ! move interface k-1 (and k-2 if necessary) upward + ! Only work on layers that are sufficiently far from the fixed near-surface layers. + if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + tenm)) then + + ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. + if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & + (h_col(k-2) > qqmx*dp0ij(k-2)) ) then + ! Determine how much water layer k-2 could supply without becoming too thin. + if (k == fixlay+3) then + ! Treat layer k-2 as fixed. + h_hat2 = max(h_hat0 - h_hat, dp0ij(k-2) - h_col(k-2)) + else + ! Maintain minimum thickess of layer k-2. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + endif !fixlay+3:else + + if (h_hat2 < -onemm) then + dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + elseif (k <= fixlay+3) then + ! Do nothing. + elseif (p_int(k-2) > dp0cum(k-2) + tenm .and. & + (p_int(nk+1) - p_int(k-2) < thkbot .or. & + h_col(k-3) > qqmx*dp0ij(k-3))) then + + ! Determine how much water layer k-3 could supply without becoming too thin. + if (k == fixlay+4) then + ! Treat layer k-3 as fixed. + h_hat3 = max(h_hat0 - h_hat, dp0ij(k-3) - h_col(k-3)) + else + ! Maintain minimum thickess of layer k-3. + h_hat3 = cushn(h_col(k-3) + (h_hat0 - h_hat), dp0ij(k-3)) - h_col(k-3) + endif !fixlay+4:else + if (h_hat3 < -onemm) then + ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. + dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) + h_col(k-3) = h_col(k-3) + dh_cor + h_col(k-2) = h_col(k-2) - dh_cor + dp_int(k-2) = dp_int(k-2) + dh_cor + p_int(k-2) = p_int(k-2) + dh_cor + + ! Now layer k-2 might be able donate to layer k-1. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + if (h_hat2 < -onemm) then + dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !h_hat2 + endif !h_hat3 + endif !h_hat2:blocking + endif ! Layer k-2 could move. + endif ! blocking, i.e., h_hat >= 0, and far enough from the fixed layers to permit a change. + + if (h_hat < 0.0) then + ! entrain layer k-1 water into layer k, move interface up. + dh_cor = qhrlx(k) * h_hat + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif !entrain + + endif !too-dense adjustment + endif + + ! In the original Hycom version, there is not a break between these two loops. + enddo + + do k=fixlay+1,nk + if (Rcv(k) < Rcv_tgt(k) - epsil) then ! layer too light + ! Water in layer k is too light, so try to dilute with water from layer k+1. + ! Entrainment is not possible if layer k touches the bottom. + if (p_int(k+1) < p_int(nk+1)) then ! k dp0ij(k) + dp0ij(k+1)) then + h_hat = h_col(k+1) - cushn(h_col(k+1) - h_hat, dp0ij(k+1)) + endif + ! Try to bring layer layer k up to its minimum thickness. + h_hat = max(h_hat, dp0ij(k) - h_col(k)) + ! Do not drive layer k+1 below its minimum thickness or take more than half of it. + h_hat = min(h_hat, max(0.5*h_col(k+1), h_col(k+1) - dp0ij(k+1)) ) + else + ! Layers that touch the bottom can lose their entire contents. + h_hat = min(h_col(k+1), h_hat) + endif !p.k+2 0.0) then + ! Entrain layer k+1 water into layer k. + dh_cor = qhrlx(k+1) * h_hat + h_col(k) = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(k+1) + dh_cor + endif !entrain + + endif !too-light adjustment + endif !above bottom + endif !too light + + ! If layer above is still too thin, move interface down. + dh_cor = min(qhrlx(k-1) * min(dp0ij(k-1) - h_col(k-1), p_int(nk+1) - p_int(k)), h_col(k)) + if (dh_cor > 0.0) then + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif + + enddo !k Hybrid vertical coordinate relocation moving interface downward + + if (trap_errors) then + ! Verify that everything is consistent. + do k=1,nk + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) + call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) + endif + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay + call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) + endif + enddo + do K=1,nk+1 + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), onem)) then + call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") + endif + enddo + endif + +end subroutine hybgen_column_regrid + +end module MOM_hybgen_regrid + +! This code was translated in 2022 from the HYCOM hybgen code, which was primarily developed +! between 2000 and 2015, with some minor subsequent changes and bug fixes. diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 new file mode 100644 index 0000000000..6e204f856b --- /dev/null +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -0,0 +1,502 @@ +!> This module contains the hybgen unmixing routines from HYCOM, with +!! modifications to follow the MOM6 coding conventions and several bugs fixed +module MOM_hybgen_unmix + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_hybgen_regrid, only : hybgen_column_init +use MOM_hybgen_regrid, only : hybgen_regrid_CS, get_hybgen_regrid_params +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_unmix_CS ; private + + integer :: nsigma !< Number of sigma levels used by HYBGEN + real :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Hybgen relaxation amount per thermodynamic time steps [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + + real :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, allocatable, dimension(:) :: target_density !< Nominal density of interfaces [R ~> kg m-3] + +end type hybgen_unmix_CS + +public hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix +public set_hybgen_unmix_params + +contains + +!> Initialise a hybgen_unmix_CS control structure and store its parameters +subroutine init_hybgen_unmix(CS, GV, US, param_file, hybgen_regridCS) + type(hybgen_unmix_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file + type(hybgen_regrid_CS), pointer :: hybgen_regridCS !< Control structure for hybgen + !! regridding for sharing parameters. + + character(len=40) :: mdl = "MOM_hybgen" ! This module's name. + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_unmix: CS already associated!") + allocate(CS) + allocate(CS%target_density(GV%ke)) + + allocate(CS%dp0k(GV%ke), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(GV%ke), source=0.0) ! minimum shallow z-layer separation + + ! Set the parameters for the hybgen unmixing from a hybgen regridding control structure. + call get_hybgen_regrid_params(hybgen_regridCS, ref_pressure=CS%ref_pressure, & + nsigma=CS%nsigma, dp0k=CS%dp0k, ds0k=CS%ds0k, & + dp00i=CS%dp00i, topiso_const=CS%topiso_const, qhybrlx=CS%qhybrlx, & + hybiso=CS%hybiso, min_dilate=CS%min_dilate, max_dilate=CS%max_dilate, & + target_density=CS%target_density) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + +end subroutine init_hybgen_unmix + +!> This subroutine deallocates memory in the control structure for the hybgen unmixing module +subroutine end_hybgen_unmix(CS) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_unmix + +!> This subroutine can be used to set the parameters for the hybgen module +subroutine set_hybgen_unmix_params(CS, min_thickness) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate unmixing control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + + if (.not. associated(CS)) call MOM_error(FATAL, "set_hybgen_params: CS not associated") + +! if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_hybgen_unmix_params + + +!> Unmix the properties in the lowest layer with mass if it is too light, and make +!! any other changes to the water column to prepare for regridding. +subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) + 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(hybgen_unmix_CS), intent(in) :: CS !< hybgen control structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + integer, intent(in) :: ntr !< The number of tracers in the registry, or + !! 0 if the registry is not in use. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + +! --- -------------------------------------------- +! --- hybrid grid generator, single j-row (part A). +! --- -------------------------------------------- + + character(len=256) :: mesg ! A string for output messages + integer :: fixlay ! deepest fixed coordinate layer + real :: qhrlx( GV%ke+1) ! relaxation coefficient per timestep [nondim] + real :: dp0ij( GV%ke) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(GV%ke+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: Rcv_tgt(GV%ke) ! Target potential density [R ~> kg m-3] + real :: temp(GV%ke) ! A column of potential temperature [degC] + real :: saln(GV%ke) ! A column of salinity [ppt] + real :: Rcv(GV%ke) ! A column of coordinate potential density [R ~> kg m-3] + real :: h_col(GV%ke) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: tracer(GV%ke,max(ntr,1)) ! Columns of each tracer [Conc] + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: h_thin ! A negligibly small thickness to identify essentially + ! vanished layers [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + + real :: Th_tot_in, Th_tot_out ! Column integrated temperature [degC H ~> degC m or degC kg m-2] + real :: Sh_tot_in, Sh_tot_out ! Column integrated salinity [ppt H ~> ppt m or ppt kg m-2] + real :: Trh_tot_in(max(ntr,1)) ! Initial column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + real :: Trh_tot_out(max(ntr,1)) ! Final column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + + logical :: debug_conservation ! If true, test for non-conservation. + logical :: terrain_following ! True if this column is terrain following. + integer :: trcflg(max(ntr,1)) ! Hycom tracer type flag for each tracer + integer :: i, j, k, nk, m + + nk = GV%ke + + ! Set all tracers to be passive. Setting this to 2 treats a tracer like temperature. + trcflg(:) = 3 + + h_thin = 1e-6*GV%m_to_H + debug_conservation = .false. ! Set this to true for debugging + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + h_tot = 0.0 + do k=1,nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + h_col(k) = h(i,j,k) + h_tot = h_tot + h_col(k) + temp(k) = tv%T(i,j,k) + saln(k) = tv%S(i,j,k) + enddo + + ! This sets the potential density from T and S. + call calculate_density(temp, saln, p_col, Rcv, tv%eqn_of_state) + + do m=1,ntr ; do k=1,nk + tracer(k,m) = Reg%Tr(m)%t(i,j,k) + enddo ; enddo + + ! Store original amounts to test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_in = 0.0 ; Sh_tot_in = 0.0 ; Trh_tot_in(:) = 0.0 + do k=1,nk + Sh_tot_in = Sh_tot_in + h_col(k)*saln(k) + Th_tot_in = Th_tot_in + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_in(m) = Trh_tot_in(m) + h_col(k)*tracer(k,m) + enddo ; enddo + endif + + ! The following block of code is used to trigger z* stretching of the targets heights. + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + + terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Do any unmixing of the column that is needed to move the layer properties toward their targets. + call hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, tv%eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + + ! Store the output from hybgen_unmix in the 3-d arrays. + do k=1,nk + h(i,j,k) = h_col(k) + enddo + ! Note that temperature and salinity are among the tracers unmixed here. + do m=1,ntr ; do k=1,nk + Reg%Tr(m)%t(i,j,k) = tracer(k,m) + enddo ; enddo + ! However, temperature and salinity may have been treated differently from other tracers. + do k=1,nk + tv%T(i,j,k) = temp(k) + tv%S(i,j,k) = saln(k) + enddo + + ! Test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_out = 0.0 ; Sh_tot_out = 0.0 ; Trh_tot_out(:) = 0.0 + do k=1,nk + Sh_tot_out = Sh_tot_out + h_col(k)*saln(k) + Th_tot_out = Th_tot_out + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m) + enddo ; enddo + if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then + write(mesg, '("i,j=",2i8,"Sh_tot = ",2es17.8," err = ",es13.4)') & + i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out) + call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg)) + endif + if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then + write(mesg, '("i,j=",2i8,"Th_tot = ",2es17.8," err = ",es13.4)') & + i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out) + call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg)) + endif + do m=1,ntr + if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then + write(mesg, '("i,j=",2i8,"Trh_tot(",i2,") = ",2es17.8," err = ",es13.4)') & + i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m)) + call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg)) + endif + enddo + endif + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_unmix + + +!> Unmix the properties in the lowest layer if it is too light. +subroutine hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen unmixing control structure + integer, intent(in) :: nk !< The number of layers + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx(nk+1) !< Relaxation fraction per timestep [nondim], < 1. + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + real, intent(inout) :: temp(nk) !< A column of potential temperature [degC] + real, intent(inout) :: saln(nk) !< A column of salinity [ppt] + real, intent(inout) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: ntr !< The number of registered passive tracers + real, intent(inout) :: tracer(nk, max(ntr,1)) !< Columns of the passive tracers [Conc] + integer, intent(in) :: trcflg(max(ntr,1)) !< Hycom tracer type flag for each tracer + real, intent(inout) :: h_col(nk+1) !< Layer thicknesses [H ~> m or kg m-2] + logical, intent(in) :: terrain_following !< True if this column is terrain following + real, intent(in) :: h_thin !< A negligibly small thickness to identify + !! essentially vanished layers [H ~> m or kg m-2] + +! +! --- ------------------------------------------------------------------ +! --- hybrid grid generator, single column - ummix lowest massive layer. +! --- ------------------------------------------------------------------ +! + ! Local variables + real :: h_hat ! A portion of a layer to move across an interface [H ~> m or kg m-2] + real :: delt, deltm ! Temperature differences between successive layers [degC] + real :: dels, delsm ! Salinity differences between successive layers [ppt] + real :: abs_dRdT ! The absolute value of the derivative of the coordinate density + ! with temperature [R degC-1 ~> kg m-3 degC-1] + real :: abs_dRdS ! The absolute value of the derivative of the coordinate density + ! with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: q, qts ! Nondimensional fractions in the range of 0 to 1 [nondim] + real :: frac_dts ! The fraction of the temperature or salinity difference between successive + ! layers by which the source layer's property changes by the loss of water + ! that matches the destination layers properties via unmixing [nondim]. + real :: qtr ! The fraction of the water that will come from the layer below, + ! used for updating the concentration of passive tracers [nondim] + real :: swap_T ! A swap variable for temperature [degC] + real :: swap_S ! A swap variable for salinity [ppt] + real :: swap_R ! A swap variable for the coordinate potential density [R ~> kg m-3] + real :: swap_tr ! A temporary swap variable for the tracers [conc] + logical, parameter :: lunmix=.true. ! unmix a too light deepest layer + integer :: k, ka, kp, kt, m + + ! --- identify the deepest layer kp with significant thickness (> h_thin) + kp = 2 !minimum allowed value + do k=nk,3,-1 + if (h_col(k) >= h_thin) then + kp = k + exit + endif + enddo !k + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 +! + if ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + ((Rcv(k-1) > Rcv(k)) .and. (Rcv(ka) > Rcv(k))) ) then +! +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the two layers above. +! --- +! --- this should only occur when relaxing or nudging layer thickness +! --- and is a bug (bad interaction with tsadvc) even in those cases +! --- +! --- entrain the entire layer into the one above +!--- note the double negative in T=T-q*(T-T'), equiv. to T=T+q*(T'-T) + q = h_col(k) / (h_col(k) + h_col(k-1)) + temp(k-1) = temp(k-1) - q*(temp(k-1) - temp(k)) + saln(k-1) = saln(k-1) - q*(saln(k-1) - saln(k)) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + tracer(k-1,m) = tracer(k-1,m) - q*(tracer(k-1,m) - tracer(k,m) ) + enddo !m +! --- entrained the entire layer into the one above, so now kp=kp-1 + h_col(k-1) = h_col(k-1) + h_col(k) + h_col(k) = 0.0 + kp = k-1 + elseif ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + (Rcv(k-1) > Rcv(k)) ) then +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the layer above, but not the layer two above. +! --- +! --- swap the entire layer with the one above. + if (h_col(k) <= h_col(k-1)) then + ! The bottom layer is thinner; swap the entire bottom layer with a portion of the layer above. + q = h_col(k) / h_col(k-1) !<=1.0 + + swap_T = temp(k-1) + temp(k-1) = temp(k-1) + q*(temp(k) - temp(k-1)) + temp(k) = swap_T + + swap_S = saln(k-1) + saln(k-1) = saln(k-1) + q*(saln(k) - saln(k-1)) + saln(k) = swap_S + + Rcv(k) = Rcv(k-1) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k-1,m) + tracer(k-1,m) = tracer(k-1,m) - q * (tracer(k-1,m) - tracer(k,m)) + tracer(k,m) = swap_tr + enddo !m + else + ! The bottom layer is thicker; swap the entire layer above with a portion of the bottom layer. + q = h_col(k-1) / h_col(k) !<1.0 + + swap_T = temp(k) + temp(k) = temp(k) + q*(temp(k-1) - temp(k)) + temp(k-1) = swap_T + + swap_S = saln(k) + saln(k) = saln(k) + q*(saln(k-1) - saln(k)) + saln(k-1) = swap_S + + Rcv(k-1) = Rcv(k) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k,m) + tracer(k,m) = tracer(k,m) + q * (tracer(k-1,m) - tracer(k,m)) + tracer(k-1,m) = swap_tr + enddo !m + endif !bottom too light + endif + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 + + if ( lunmix .and. & ! usually .true. + ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv(k) < Rcv_tgt(k)) .and. & ! layer is lighter than its target + (Rcv(k) > Rcv_tgt(k-1)) .and. & ! layer is denser than the target above + (abs(Rcv_tgt(k-1) - Rcv(k-1)) < CS%hybiso) .and. & ! layer above is near its target + (Rcv(k) - Rcv(k-1) > 0.001*(Rcv_tgt(k) - Rcv_tgt(k-1))) ) then +! +! --- water in the deepest inflated layer with significant thickness (kp) is too +! --- light but denser than the layer above, with the layer above near-isopycnal +! --- +! --- split layer into 2 sublayers, one near the desired density +! --- and one exactly matching the T&S properties of layer k-1. +! --- To prevent "runaway" T or S, the result satisfies either +! --- abs(T.k - T.k-1) <= abs(T.k-N - T.k-1) or +! --- abs(S.k - S.k-1) <= abs(S.k-N - S.k-1) where +! --- Rcv.k-1 - Rcv.k-N is at least Rcv_tgt(k-1) - Rcv_tgt(k-2) +! --- It is also limited to a 50% change in layer thickness. + + ka = 1 + do kt=k-2,2,-1 + if ( Rcv(k-1) - Rcv(kt) >= Rcv_tgt(k-1) - Rcv_tgt(k-2) ) then + ka = kt !usually k-2 + exit + endif + enddo + + delsm = abs(saln(ka) - saln(k-1)) + dels = abs(saln(k-1) - saln(k)) + deltm = abs(temp(ka) - temp(k-1)) + delt = abs(temp(k-1) - temp(k)) + + call calculate_density_derivs(temp(k-1), saln(k-1), CS%ref_pressure, abs_dRdT, abs_dRdS, eqn_of_state) + ! Bound deltm and delsm based on the equation of state and density differences between layers. + abs_dRdT = abs(abs_dRdT) ; abs_dRdS = abs(abs_dRdS) + if (abs_dRdT * deltm > Rcv_tgt(k)-Rcv_tgt(k-1)) deltm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdT + if (abs_dRdS * delsm > Rcv_tgt(k)-Rcv_tgt(k-1)) delsm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdS + + qts = 0.0 + if (qts*dels < min(delsm-dels, dels)) qts = min(delsm-dels, dels) / dels + if (qts*delt < min(deltm-delt, delt)) qts = min(deltm-delt, delt) / delt + + ! Note that Rcv_tgt(k) > Rcv(k) > Rcv(k-1), and 0 <= qts <= 1. + ! qhrlx is relaxation coefficient (inverse baroclinic time steps), 0 <= qhrlx <= 1. + ! This takes the minimum of the two estimates. + if ((1.0+qts) * (Rcv_tgt(k)-Rcv(k)) < qts * (Rcv_tgt(k)-Rcv(k-1))) then + q = qhrlx(k) * ((Rcv_tgt(k)-Rcv(k)) / (Rcv_tgt(k)-Rcv(k-1))) + else + q = qhrlx(k) * (qts / (1.0+qts)) ! upper sublayer <= 50% of total + endif + frac_dts = q / (1.0-q) ! 0 <= q <= 0.5, so 0 <= frac_dts <= 1 + + h_hat = q * h_col(k) + h_col(k-1) = h_col(k-1) + h_hat + h_col(k) = h_col(k) - h_hat + + temp(k) = temp(k) + frac_dts * (temp(k) - temp(k-1)) + saln(k) = saln(k) + frac_dts * (saln(k) - saln(k-1)) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + if ((ntr > 0) .and. (h_hat /= 0.0)) then + ! qtr is the fraction of the new upper layer from the old lower layer. + ! The nonconservative original from Hycom: qtr = h_hat / max(h_hat, h_col(k)) !between 0 and 1 + qtr = h_hat / h_col(k-1) ! Between 0 and 1, noting the h_col(k-1) = h_col(k-1) + h_hat above. + do m=1,ntr + if (trcflg(m) == 2) then !temperature tracer + tracer(k,m) = tracer(k,m) + frac_dts * (tracer(k,m) - tracer(k-1,m)) + else !standard tracer - not split into two sub-layers + tracer(k-1,m) = tracer(k-1,m) + qtr * (tracer(k,m) - tracer(k-1,m)) + endif !trcflg + enddo !m + endif !tracers + endif !too light + +! ! Fill properties of massless or near-massless (thickness < h_thin) layers +! ! This was in the Hycom verion, but it appears to be unnecessary in MOM6. +! do k=kp+1,nk +! ! --- fill thin and massless layers on sea floor with fluid from above +! Rcv(k) = Rcv(k-1) +! do m=1,ntr +! tracer(k,m) = tracer(k-1,m) +! enddo !m +! saln(k) = saln(k-1) +! temp(k) = temp(k-1) +! enddo !k + +end subroutine hybgen_column_unmix + +end module MOM_hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 4c99ce457d..e7680df0c2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -21,7 +21,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike @@ -31,6 +31,8 @@ module MOM_regridding use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt +use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid +use MOM_hybgen_regrid, only : write_Hybgen_coord_file implicit none ; private @@ -119,17 +121,21 @@ module MOM_regridding !! If false, use more robust forms of the same remapping expressions. logical :: remap_answers_2018 = .true. + logical :: use_hybgen_unmix = .false. !< If true, use the hybgen unmixing code before remapping + type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator + type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding end type ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main +public regridding_preadjust_reqs, convective_adjustment public inflate_vanished_layers_old, check_remapping_grid, check_grid_column public set_regrid_params, get_regrid_size, write_regrid_file public uniformResolution, setCoordinateResolution @@ -148,6 +154,7 @@ module MOM_regridding " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& + " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" @@ -458,6 +465,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! This is a work around to apparently needed to work with the from_Z initialization... ??? if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & + coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then ! Adjust target grid to be consistent with maximum_depth @@ -511,7 +519,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, US, coord_mode) + call initCoord(CS, GV, US, coord_mode, param_file) if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "P_REF", P_Ref, & @@ -536,6 +544,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, min_thickness=0.) endif + CS%use_hybgen_unmix = .false. + if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then + call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & + "If true, use hybgen unmixing code before regridding.", & + default=.false.) + endif + if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & @@ -744,6 +759,7 @@ subroutine end_regridding(CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) + if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) deallocate( CS%coordinateResolution ) if (allocated(CS%target_density)) deallocate( CS%target_density ) @@ -816,6 +832,9 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) + case ( REGRIDDING_HYBGEN ) + call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SLIGHT ) call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -835,6 +854,39 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end subroutine regridding_main +!------------------------------------------------------------------------------ +!> This routine returns flags indicating which pre-remapping state adjustments +!! are needed depending on the coordinate mode in use. +subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS) + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, intent(out) :: do_conv_adj !< Convective adjustment should be done + logical, intent(out) :: do_hybgen_unmix !< Hybgen unmixing should be done + type(hybgen_regrid_CS), pointer, & + optional, intent(out) :: hybgen_CS !< Control structure for hybgen regridding for sharing parameters. + + + do_conv_adj = .false. ; do_hybgen_unmix = .false. + select case ( CS%regridding_scheme ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & + REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + do_conv_adj = .false. ; do_hybgen_unmix = .false. + case ( REGRIDDING_RHO ) + do_conv_adj = .true. ; do_hybgen_unmix = .false. + case ( REGRIDDING_HYBGEN ) + do_conv_adj = .false. ; do_hybgen_unmix = CS%use_hybgen_unmix + case default + call MOM_error(FATAL,'MOM_regridding, regridding_preadjust_reqs: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + + if (present(hybgen_CS) .and. do_hybgen_unmix) hybgen_CS => CS%hybgen_CS + +end subroutine regridding_preadjust_reqs + + !> Calculates h_new from h + delta_k dzInterface subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1869,14 +1921,17 @@ subroutine convective_adjustment(G, GV, h, tv) !------------------------------------------------------------------------------ ! Local variables - integer :: i, j, k - real :: T0, T1 ! temperatures - real :: S0, S1 ! salinities - real :: r0, r1 ! densities - real :: h0, h1 + real :: T0, T1 ! temperatures of two layers [degC] + real :: S0, S1 ! salinities of two layers [ppt] + real :: r0, r1 ! densities of two layers [R ~> kg m-3] + real :: h0, h1 ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(GV%ke) :: p_col ! A column of zero pressures [R L2 T-2 ~> Pa] + real, dimension(GV%ke) :: densities ! Densities in the column [R ~> kg m-3] logical :: stratified - real, dimension(GV%ke) :: p_col, densities + integer :: i, j, k + !### Doing convective adjustment based on potential densities with zero pressure seems + ! questionable, although it does avoid ambiguous sorting. -RWH p_col(:) = 0. ! Loop on columns @@ -1905,6 +1960,8 @@ subroutine convective_adjustment(G, GV, h, tv) call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) + ! Because p_col is has uniform values, these calculate_density calls are equivalent to + ! densities(k) = r1 ; densities(k+1) = r0 stratified = .false. endif enddo ! k @@ -1940,8 +1997,8 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_SIGMA_SHELF_ZSTAR, & - REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) case ( REGRIDDING_RHO ) @@ -1960,13 +2017,14 @@ end function uniformResolution !> Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, US, coord_mode) +subroutine initCoord(CS, GV, US, coord_mode, param_file) type(regridding_CS), intent(inout) :: CS !< Regridding control structure character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1980,6 +2038,8 @@ subroutine initCoord(CS, GV, US, coord_mode) case (REGRIDDING_HYCOM1) call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & CS%interp_CS) + case (REGRIDDING_HYBGEN) + call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) case (REGRIDDING_SLIGHT) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & CS%interp_CS, GV%m_to_H) @@ -2121,6 +2181,11 @@ subroutine write_regrid_file( CS, GV, filepath ) type(file_type) :: IO_handle ! The I/O handle of the fileset real :: ds(GV%ke), dsi(GV%ke+1) + if (CS%regridding_scheme == REGRIDDING_HYBGEN) then + call write_Hybgen_coord_file(GV, CS%hybgen_CS, filepath) + return + endif + ds(:) = CS%coord_scale * CS%coordinateResolution(:) dsi(1) = 0.5*ds(1) dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) @@ -2209,7 +2274,8 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) getCoordinateUnits = 'meter/fraction' @@ -2247,6 +2313,8 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'coordinate' case ( REGRIDDING_HYCOM1 ) getCoordinateShortName = 'z-rho' + case ( REGRIDDING_HYBGEN ) + getCoordinateShortName = 'hybrid' case ( REGRIDDING_SLIGHT ) getCoordinateShortName = 's-rho' case ( REGRIDDING_ADAPTIVE ) @@ -2341,6 +2409,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri case (REGRIDDING_HYCOM1) if (associated(CS%hycom_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) + case (REGRIDDING_HYBGEN) + ! Do nothing for now. case (REGRIDDING_SLIGHT) if (present(min_thickness)) call set_slight_params(CS%slight_CS, min_thickness=min_thickness) if (present(dz_min_surface)) call set_slight_params(CS%slight_CS, dz_ml_min=dz_min_surface) @@ -2409,7 +2479,8 @@ function getStaticThickness( CS, SSH, depth ) real :: z, dz select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 7e8edea344..9fe638dd5b 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -21,6 +21,7 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier +integer, parameter :: REGRIDDING_HYBGEN = 10 !< Hybgen coordinates identifier character(len=*), parameter :: REGRIDDING_LAYER_STRING = "LAYER" !< Layer string character(len=*), parameter :: REGRIDDING_ZSTAR_STRING_OLD = "Z*" !< z* string (legacy name) @@ -29,6 +30,7 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_SIGMA_STRING = "SIGMA" !< Sigma string character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string +character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string @@ -60,6 +62,7 @@ function coordinateMode(string) case (trim(REGRIDDING_RHO_STRING)); coordinateMode = REGRIDDING_RHO case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 + case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR @@ -81,6 +84,7 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_RHO); coordinateUnitsI = "kg m^-3" case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" + case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& @@ -116,6 +120,7 @@ logical function state_dependent_int(mode) case (REGRIDDING_RHO); state_dependent_int = .true. case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. + case (REGRIDDING_HYBGEN); state_dependent_int = .true. case (REGRIDDING_SLIGHT); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4e8dd4f186..83f0b618c2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -88,12 +88,10 @@ module MOM_state_initialization use dumbbell_initialization, only : dumbbell_initialize_sponges use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord -use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated -use MOM_ALE, only : TS_PLM_edge_values +use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution -use MOM_regridding, only : regridding_main -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h +use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd use MOM_oda_incupd, only: set_up_oda_incupd_field, set_up_oda_incupd_vel_field @@ -212,7 +210,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & use_EOS = associated(tv%eqn_of_state) use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state - use_ice_shelf=PRESENT(frac_shelf_h) + use_ice_shelf = PRESENT(frac_shelf_h) !==================================================================== ! Initialize temporally evolving fields, either as initial @@ -2439,18 +2437,21 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! data arrays real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] - real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z + real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [degC] + real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [ppt] + real, dimension(:,:,:), allocatable, target :: mask_z ! 1 for valid data points [nondim] real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor ! relative to the surface [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs ! The number of levels in each column with valid data real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. - real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn - real, dimension(:,:,:), allocatable :: tmp_mask_in + real, dimension(:,:,:), allocatable, target :: tmpT1dIn ! Input temperatures on a model-sized grid [degC] + real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [ppt] + real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. @@ -2459,7 +2460,6 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 - logical :: use_ice_shelf logical :: pre_gridded logical :: separate_mixed_layer ! If true, handle the mixed layers differently. logical :: density_extrap_bug ! If true use an expression with a vertical indexing bug for @@ -2467,7 +2467,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! from data when finding the initial interface locations in ! layered mode from a dataset of T and S. character(len=64) :: remappingScheme - real :: tempAvg, saltAvg + real :: tempAvg ! Spatially averaged temperatures on a layer [degC] + real :: saltAvg ! Spatially averaged salinities on a layer [ppt] + logical :: do_conv_adj, ignore integer :: nPoints, ans integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE @@ -2493,8 +2495,6 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - use_ice_shelf = present(frac_shelf_h) - call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE", filename, & "The name of the z-space input file used to initialize "//& "temperatures (T) and salinities (S). If T and S are not "//& @@ -2722,11 +2722,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just GV_loc = GV GV_loc%ke = nkd allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h ) - else - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface ) - endif + + call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) + if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h, & + conv_adjust=.false. ) + deallocate( dz_interface ) endif call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & From 28ff86e4e7db3f125f36037f44eec5807f5f88b9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 12:21:01 -0400 Subject: [PATCH 137/155] +Convective adjustment outside regridding_main Eliminated the option to do convective adjustment within regridding_main, including making the optional argument conv_adjust mandatory, with an error message if it is set to .true., so that there will not be the possibility of this code change silently changing the code behavior or solutions. After a decent interval, this argument can be safely eliminated. As a result of these changes, the intent of two key arguments to regridding_main() could be changed from intent(inout) to intent(in), which should help clarify the purpose of this routine. All answers are bitwise identical, but there are interface changes. --- src/ALE/MOM_ALE.F90 | 4 ++-- src/ALE/MOM_regridding.F90 | 24 ++++++++++++------- .../MOM_state_initialization.F90 | 4 ++-- 3 files changed, 19 insertions(+), 13 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 97303aa100..876c2c684b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -426,8 +426,8 @@ 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. - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & - frac_shelf_h, conv_adjust=.false., PCM_cell=PCM_cell) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e7680df0c2..78159146a2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -770,8 +770,8 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, & - conv_adjust, PCM_cell) +subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, conv_adjust, & + frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between ! the old grid and the new grid. The creation of the new grid can be based @@ -794,22 +794,29 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after !! the last time step - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface + logical, intent(in ) :: conv_adjust !< If true, regridding_main should do + !! convective adjustment, but because it no + !! longer does convective adjustment this must + !! be false. This argument has been retained to + !! trap inconsistent code, but will eventually + !! be eliminated. real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables real :: trickGnuCompiler - logical :: do_convective_adjustment - do_convective_adjustment = .true. - if (present(conv_adjust)) do_convective_adjustment = conv_adjust + if (conv_adjust) call MOM_error(FATAL, & + "regridding_main: convective adjustment no longer is done inside of regridding_main. "//& + "The code needs to be modified to call regridding_main() with conv_adjust=.false, "//& + "and a call to convective_adjustment added before calling regridding_main() "//& + "if regridding_preadjust_reqs() indicates that this is necessary.") if (present(PCM_cell)) PCM_cell(:,:,:) = .false. select case ( CS%regridding_scheme ) @@ -824,7 +831,6 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call build_sigma_grid( CS, G, GV, h, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - if (do_convective_adjustment) call convective_adjustment(G, GV, h, tv) call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 83f0b618c2..ee3052f166 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2725,8 +2725,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h, & - conv_adjust=.false. ) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h ) deallocate( dz_interface ) endif From 6809ee3a45f957c84276bf919736947d8f8ea18a Mon Sep 17 00:00:00 2001 From: He Wang <35150900+herrwang0@users.noreply.github.com> Date: Sun, 10 Apr 2022 11:35:28 -0400 Subject: [PATCH 138/155] Fix tides_CS attribute in unsplit mode (#103) Remove the pointer attribute from tides_CS in its parent CS in unsplit mode. This recovers tidal forcing functionality in the unsplit mode. --- src/core/MOM_dynamics_unsplit.F90 | 2 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 9a58dddd0f..085b4e02c3 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -154,7 +154,7 @@ module MOM_dynamics_unsplit !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index ec4a1aa843..91aaca508e 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -156,7 +156,7 @@ module MOM_dynamics_unsplit_RK2 !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() From c150f37a155b486fe08928cce15e308e2603f274 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sun, 10 Apr 2022 12:06:39 -0400 Subject: [PATCH 139/155] Correct --with-driver args for coupled tests (#106) - Ever since a renaming of driver directories, the tests under "test-top-api", that are meant to check we are compatible with each "cap", have been failing silently. - This fixes the wrong arguments but does not fix the ability to fail silently which is somewhere deep inside mkmf. --- .testing/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index f330c92e3b..4096436f30 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -265,9 +265,9 @@ build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp build/target/Makefile: MOM_ACFLAGS= build/opt/Makefile: MOM_ACFLAGS= build/opt_target/Makefile: MOM_ACFLAGS= -build/coupled/Makefile: MOM_ACFLAGS=--with-driver=coupled_driver -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_driver -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_driver +build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap +build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap +build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_cap # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) From e9fdf5de35122a30adfcec7058d0e59cc57d0cb9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Apr 2022 18:33:38 -0400 Subject: [PATCH 140/155] Standardized syntax in mask2d logical tests Modified the syntax of the logical comparisons with the various mask2d variables to always check whether they are larger than 0.0, not 0.5 and use similar syntax throughout the MOM6 code. Because these arrays are always either 0.0 or 1.0, the answers are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 22 ++++++------ .../mct_cap/mom_surface_forcing_mct.F90 | 18 +++++----- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 18 +++++----- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 12 +++---- src/ALE/coord_adapt.F90 | 8 ++--- src/core/MOM_forcing_type.F90 | 16 ++++----- src/diagnostics/MOM_wave_speed.F90 | 4 +-- src/diagnostics/MOM_wave_structure.F90 | 6 ++-- .../vertical/MOM_ALE_sponge.F90 | 24 ++++++------- .../vertical/MOM_diabatic_aux.F90 | 10 +++--- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- .../vertical/MOM_entrain_diffusive.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_opacity.F90 | 10 +++--- .../vertical/MOM_set_diffusivity.F90 | 26 +++++++------- .../vertical/MOM_set_viscosity.F90 | 6 ++-- src/parameterizations/vertical/MOM_sponge.F90 | 4 +-- .../vertical/MOM_vert_friction.F90 | 12 +++---- src/tracer/MOM_generic_tracer.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 10 +++--- src/tracer/MOM_offline_aux.F90 | 10 +++--- src/tracer/MOM_tracer_diabatic.F90 | 36 +++++++++---------- src/tracer/MOM_tracer_hor_diff.F90 | 18 +++++----- src/tracer/boundary_impulse_tracer.F90 | 2 +- src/tracer/ideal_age_example.F90 | 2 +- 28 files changed, 143 insertions(+), 145 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index acbbc292de..faa74a7fe0 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -374,7 +374,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -956,13 +956,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux).and.present(tauy)) then do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -984,14 +984,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif @@ -1029,10 +1029,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0.0)) .or. & ((wind_stagger == BGRID_NE) .and. & (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) @@ -1050,7 +1050,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & @@ -1069,7 +1069,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) @@ -1080,10 +1080,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, else ! C-grid wind stresses. do j=js,je ; do i=is,ie taux2 = 0.0 ; tauy2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) tau_mag = sqrt(taux2 + tauy2) diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 7b32270b4c..a8a3ea0c69 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -385,7 +385,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -749,7 +749,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -757,7 +757,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -770,7 +770,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -786,7 +786,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -794,7 +794,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -802,7 +802,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo; enddo @@ -814,12 +814,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index c704214930..d04ecf10e4 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -410,7 +410,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -806,7 +806,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -814,7 +814,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -827,7 +827,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -843,7 +843,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -851,7 +851,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -859,7 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -871,12 +871,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 300c736802..9c67be4829 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -172,7 +172,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7c26c2f194..7bca03ca5d 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1125,7 +1125,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1138,7 +1138,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1231,7 +1231,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%restorebuoy) then if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1244,7 +1244,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1431,7 +1431,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & @@ -1446,7 +1446,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then + ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index fe3864fc7a..e5b33103ef 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -154,7 +154,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! TODO: this needs to be adjusted to account for vanished layers near topography ! up (j-1) - if (G%mask2dT(i,j-1) > 0.) then + if (G%mask2dT(i,j-1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & @@ -166,7 +166,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j-1,2:nz) - sInt(i,j,2:nz))) endif ! down (j+1) - if (G%mask2dT(i,j+1) > 0.) then + if (G%mask2dT(i,j+1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & @@ -178,7 +178,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j+1,2:nz) - sInt(i,j,2:nz))) endif ! left (i-1) - if (G%mask2dT(i-1,j) > 0.) then + if (G%mask2dT(i-1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & @@ -190,7 +190,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i-1,j,2:nz) - sInt(i,j,2:nz))) endif ! right (i+1) - if (G%mask2dT(i+1,j) > 0.) then + if (G%mask2dT(i+1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ccd70cd9da..6de46f7738 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2184,12 +2184,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) associated(fluxes%ustar_gustless)) then do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + & G%mask2dCu(I,j) * forces%taux(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) @@ -3518,15 +3518,15 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) if (do_stress) then tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=js,je ; do i=isB,ieB - if (G%mask2dCu(I,j) > 0.) forces%taux(I,j) = tx_mean + if (G%mask2dCu(I,j) > 0.0) forces%taux(I,j) = tx_mean enddo ; enddo ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) forces%tauy(i,J) = ty_mean + if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) + if (G%mask2dT(i,j) > 0.0) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) enddo ; enddo else call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) @@ -3689,7 +3689,7 @@ subroutine homogenize_field_t(var, G, tmp_scale) avg = global_area_mean(var, G, tmp_scale=tmp_scale) do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) var(i,j) = avg + if (G%mask2dT(i,j) > 0.0) var(i,j) = avg enddo ; enddo end subroutine homogenize_field_t @@ -3706,7 +3706,7 @@ subroutine homogenize_field_v(var, G, tmp_scale) avg = global_area_mean_v(var, G, tmp_scale=tmp_scale) do J=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) var(i,J) = avg + if (G%mask2dCv(i,J) > 0.0) var(i,J) = avg enddo ; enddo end subroutine homogenize_field_v @@ -3723,7 +3723,7 @@ subroutine homogenize_field_u(var, G, tmp_scale) avg = global_area_mean_u(var, G, tmp_scale=tmp_scale) do j=js,je ; do I=isB,ieB - if (G%mask2dCu(I,j) > 0.) var(I,j) = avg + if (G%mask2dCu(I,j) > 0.0) var(I,j) = avg enddo ; enddo end subroutine homogenize_field_u diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 0f3b19f2e1..50933abe07 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -262,7 +262,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif ! From this point, we can work on individual columns without causing memory to have page faults. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) @@ -815,7 +815,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index c833e973c5..81c8799828 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -272,12 +272,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! From this point, we can work on individual columns without causing memory ! to have page faults. - do i=is,ie ; if (cn(i,j)>0.0)then + do i=is,ie ; if (cn(i,j) > 0.0) then !----for debugging, remove later---- ig = i + G%idg_offset ; jg = j + G%jdg_offset !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then gprime(:) = 0.0 ! init gprime pres(:) = 0.0 ! init pres @@ -567,7 +567,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !else ! if at test point - delete later ! return ! if at test point - delete later !endif ! if at test point - delete later - endif ! mask2dT > 0.5? + endif ! mask2dT > 0.0? else ! if cn=0.0, default to zero nzm = nz+1! could use actual values diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index f711ef3f87..446cdb8b45 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -230,7 +230,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -241,7 +241,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 @@ -282,7 +282,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo @@ -295,7 +295,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Store the column indices and restoring rates in the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = I ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(I,j) col = col + 1 @@ -326,7 +326,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo endif do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -339,7 +339,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -492,7 +492,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo if (CS%num_col > 0) then @@ -502,7 +502,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col + 1 @@ -532,7 +532,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_u = 0 ; do j=G%jsc,G%jec; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -542,7 +542,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col + 1 @@ -564,7 +564,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_v = 0 ; do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo if (CS%num_col_v > 0) then @@ -574,7 +574,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6f1988c295..7aec4c0331 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -527,7 +527,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) do j=js,je do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_w(i) = G%areaCu(I-1,j) * Idenom a_e(i) = G%areaCu(I,j) * Idenom @@ -536,7 +536,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) endif sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_s(i) = G%areaCv(i,J-1) * Idenom a_n(i) = G%areaCv(i,J) * Idenom @@ -618,7 +618,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow ! same value is assumed for all layers. 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 + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -768,7 +768,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! endif call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) - do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then + do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo endif @@ -1227,7 +1227,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t else netMassIn(i) = netMassInOut(i) - netMassOut(i) endif - if (G%mask2dT(i,j)>0.0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%netMassOut(i,j) = netMassOut(i) fluxes%netMassIn(i,j) = netMassIn(i) else diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 379275196e..eb592fb890 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -81,7 +81,7 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) "Module must be initialized before it is used.") !$OMP do - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo else diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..98ab99616f 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -390,7 +390,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! homogenizing the shortwave heating within that cell. This sets the energy ! and ustar and wstar available to drive mixing at the first interior ! interface. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index fdc38ebf1e..45d442f98c 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -288,7 +288,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo ; enddo endif - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 300cdcbe1e..7af12aee6f 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -253,7 +253,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a44a7aee95..8af8727246 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -197,7 +197,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- ! Work on each column. !--------------------------------------- - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! call cpu_clock_begin(id_clock_setup) ! Store a transposed version of the initial arrays. ! Any elimination of massless layers would occur here. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 9aa8fafd14..66b7a7746e 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -290,7 +290,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir 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 - if ((G%mask2dT(i,j) > 0.5) .and. (chl_3d(i,j,k) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .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.")') & chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) @@ -300,7 +300,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir elseif (present(chl_2d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_2d(i,j) ; enddo ; enddo do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", & & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -316,7 +316,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_vis_tot,SW_nir_tot) do j=js,je ; do i=is,ie SW_vis_tot = 0.0 ; SW_nir_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_vis_tot = sw_vis_dir(i,j) + sw_vis_dif(i,j) elseif (total_sw_input) then @@ -344,7 +344,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_pen_tot) do j=js,je ; do i=is,ie SW_pen_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) elseif (total_sw_input) then @@ -385,7 +385,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir case (MOREL_88) do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = CS%opacity_land_value - if (G%mask2dT(i,j) > 0.5) & + if (G%mask2dT(i,j) > 0.0) & optics%opacity_band(1,i,j,k) = US%Z_to_m * opacity_morel(chl_data(i,j)) do n=2,optics%nbands diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 061fe776e1..0d5f1a9ca9 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -503,7 +503,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. - if (CS%bottomdraglaw .and. (CS%BBL_effic>0.0)) then + if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int_2d, G, GV, US, CS, & dd%Kd_BBL, Kd_lay_2d) @@ -812,7 +812,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 i_rem = 0 @@ -969,7 +969,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) @@ -1001,7 +1001,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 @@ -1195,7 +1195,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_diag_Kd_BBL = associated(Kd_BBL) - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return cdrag_sqrt = sqrt(CS%cdrag) TKE_Ray = 0.0 ; Rayleigh_drag = .false. @@ -1238,7 +1238,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) htot(i) = GV%H_to_Z*h(i,j,nz) rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) Rho_top(i) = GV%Rlay(1) @@ -1259,7 +1259,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (.not.domore) exit enddo ! k-loop - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=nz-1,kb_min,-1 i_rem = 0 do i=is,ie ; if (do_i(i)) then @@ -1409,7 +1409,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real, parameter :: von_karm = 0.41 ! Von Karman constant (http://en.wikipedia.org/wiki/Von_Karman_constant) logical :: do_diag_Kd_BBL - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. @@ -1568,7 +1568,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, if (.not.CS%ML_radiation) return - do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then @@ -1734,7 +1734,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and ! vertical decay scale. - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. ; vhtot(i) = 0.0 ; htot(i) = 0.0 vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) else @@ -1775,7 +1775,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (htot(i) > 0.0)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then v2_bbl(i,J) = (vhtot(i)*vhtot(i))/(htot(i)*htot(i)) else v2_bbl(i,J) = 0.0 @@ -1783,7 +1783,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) enddo !$OMP do do j=js,je - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) else @@ -1823,7 +1823,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (htot(i) > 0.0)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then u2_bbl(I) = (uhtot(I)*uhtot(I))/(htot(I)*htot(I)) else u2_bbl(I) = 0.0 diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 92e7b44128..93a71f6b64 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -385,15 +385,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (j 0) do_i(i) = .true. + do_i(i) = (G%mask2dCu(I,j) > 0.0) enddo else ! m=2 refers to v-points is = G%isc ; ie = G%iec do i=is,ie - do_i(i) = .false. - if (G%mask2dCv(i,J) > 0) do_i(i) = .true. + do_i(i) = (G%mask2dCv(i,J) > 0.0) enddo endif diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index d0d64079c3..dee80b9e40 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -131,7 +131,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -143,7 +143,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d384500c3d..d6c93a5211 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -256,7 +256,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq @@ -383,7 +383,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie @@ -593,7 +593,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq Ray(I,k) = visc%Ray_u(I,j,k) @@ -622,7 +622,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Now find the meridional viscous remnant using the robust tridiagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie Ray(i,k) = visc%Ray_v(i,J,k) @@ -766,7 +766,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq kv_bbl(I) = visc%Kv_bbl_u(I,j) @@ -931,7 +931,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie kv_bbl(i) = visc%Kv_bbl_v(i,J) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 31acb51160..5e8632f1ca 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -361,7 +361,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 61715e044b..08361ba9af 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) 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 - if (G%mask2dT(i,j) > 0.) then + if (G%mask2dT(i,j) > 0.0) then call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) endif enddo; enddo @@ -463,7 +463,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at U points do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) then + if (G%mask2dCu(I,j) > 0.0) then if (CS%continuous_reconstruction) then 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,:), & @@ -484,7 +484,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at V points do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) then + if (G%mask2dCv(i,J) > 0.0) then if (CS%continuous_reconstruction) then 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,:), & @@ -519,10 +519,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) 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 + if (G%mask2dCu(I,j) > 0.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 + if (G%mask2dCv(i,J) > 0.0) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H enddo ; enddo ; enddo endif endif diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index bdd6be4fe0..fdf199d71e 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -179,7 +179,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) (max(0.0, -vh(i,J-1,k)) + max(0.0, vh(i,J,k)))) + & (max(0.0, top_flux(i,j,k)) + max(0.0, bottom_flux(i,j,k))) * G%areaT(i,j) - if (pos_flux>hvol .and. pos_flux>0.0) then + if ((pos_flux > hvol) .and. (pos_flux > 0.0)) then scale_factor = (hvol / pos_flux) * max_off_cfl else ! Don't scale scale_factor = 1.0 @@ -405,7 +405,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) do k=1,nz uh_remain = uh2d(I,k) uh2d(I,k) = 0.0 - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then do k_rev = k,1,-1 uh_sum = uh_remain + uh2d(I,k_rev) if (uh_sum<0.0) then ! Transport to the left @@ -436,7 +436,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) enddo ! k_rev endif - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then if (k0.0) then + if (abs(vh_remain) > 0.0) then do k_rev = k,1,-1 vh_sum = vh_remain + vh2d(J,k_rev) if (vh_sum<0.0) then ! Transport to the left @@ -535,7 +535,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) enddo ! k_rev endif - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then if (k 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ea(i,j,k) + sink(i,K)) + & h_neglect @@ -164,7 +164,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ea(i,j,k) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ea(i,j,nz) + sink(i,nz)) + & h_neglect @@ -173,25 +173,25 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ea(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ea(i,j,1) 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) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ea(i,j,k) @@ -199,7 +199,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ea(i,j,k) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ea(i,j,nz) @@ -207,7 +207,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ea(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -345,14 +345,14 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ent(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ent(i,j,K) + sink(i,K)) + & h_neglect @@ -362,7 +362,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ent(i,j,K) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ent(i,j,nz) + sink(i,nz)) + & h_neglect @@ -371,25 +371,25 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ent(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ent(i,j,1) 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) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ent(i,j,K) @@ -397,7 +397,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ent(i,j,K) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ent(i,j,nz) @@ -405,7 +405,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ent(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 850480e3e6..3d2b322759 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -728,7 +728,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) !$OMP parallel do default(shared) private(k_min,k_max,k_test) - do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then + do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.0) then if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else @@ -756,7 +756,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel default(shared) private(ns,tmp,itmp) !$OMP do do j=js-1,je+1 - do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if (h(i,j,k) > h_exclude) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -764,7 +764,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo - do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -812,7 +812,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Set up the pairings for fluxes through the zonal faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -965,7 +965,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Set up the pairings for fluxes through the meridional faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -1120,7 +1120,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & !$OMP Tr_flux,Tr_adj_vert,wt_a,vol) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Determine the fluxes through the zonal faces. ! Find the acceptable range of tracer concentration around this face. @@ -1260,7 +1260,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Determine the fluxes through the meridional faces. ! Find the acceptable range of tracer concentration around this face. @@ -1377,7 +1377,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP tr_flux_conv,Tr_flux_3d,k0a_Lv,Tr_adj_vert_L,& !$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & !$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) - do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.5) then + do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then do k=1,nPv(i,J) kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) if (deep_wt_Lv(J)%p(i,k) >= 1.0) then @@ -1402,7 +1402,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif ; enddo ; enddo !$OMP parallel do default(none) shared(PEmax_kRho,is,ie,js,je,G,h,Tr,tr_flux_conv,m) do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (h(i,j,k) > 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / & (h(i,j,k)*G%areaT(i,j)) tr_flux_conv(i,j,k) = 0.0 diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index f85623bbd1..4f5a3ea873 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -270,7 +270,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if (CS%remaining_source_time>0.0) then + if (CS%remaining_source_time > 0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 5913251b14..a809e77a4c 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -352,7 +352,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) endif do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = sfc_val else CS%tr(i,j,k,m) = CS%land_val(m) From 7a147ad412ddea6f281110a68fd053563b24cd39 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Apr 2022 10:38:15 -0400 Subject: [PATCH 141/155] +Document or eliminate undocumented interfaces Address undocumented interfaces by adding explicit interfaces to replaces one level of the pass-throughs or eliminated them. Specifically - Eliminated global_field_sum() from MOM_domains, as it is no longer used anywhere in the MOM6 code or drivers. At the config_src/infra level, the pass-through calls to mpp_global_sum are commented out in case there are other versions of the MOM6 code that still use global_field_sum. - Added explicit interfaces to horizontal_interp_init() and time_interp_extern_init() in the config_src/infra rather that leaving them as undocumented pass-throughs to the FMS code. - Added the explicit subroutine stdout_if_root() to MOM_io.F90 to replace an undocumented pass-through to the FMS stdout function. - Added comments describing the publicly visible encoding parameters ind_flux, ind_alpha, and ind_csurf that are a part of the coupler_types module. - Removed the unnecessary or commented-out public declarations for post_data_1d_k, vert_fill_TS, and legacy_diabatic. All answers are bitwise identical, but there are some minor changes to the names of subroutines offered at the config_src/infra level to permit the documentation of these interfaces without running afoul of some bugs with certain versions of the gnu compiler. --- .../drivers/mct_cap/mom_surface_forcing_mct.F90 | 1 - .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 1 - config_src/infra/FMS1/MOM_domain_infra.F90 | 6 +++--- config_src/infra/FMS1/MOM_interp_infra.F90 | 14 ++++++++++++-- config_src/infra/FMS2/MOM_domain_infra.F90 | 6 +++--- config_src/infra/FMS2/MOM_interp_infra.F90 | 15 ++++++++++++--- src/framework/MOM_coupler_types.F90 | 4 +++- src/framework/MOM_diag_mediator.F90 | 1 - src/framework/MOM_domains.F90 | 7 ++----- src/framework/MOM_horizontal_regridding.F90 | 9 +++++---- src/framework/MOM_interpolate.F90 | 6 +++--- src/framework/MOM_io.F90 | 6 +++++- .../lateral/MOM_thickness_diffuse.F90 | 1 - .../vertical/MOM_diabatic_driver.F90 | 1 - 14 files changed, 48 insertions(+), 30 deletions(-) diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index a8a3ea0c69..ebb63865b7 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -9,7 +9,6 @@ module MOM_surface_forcing_mct use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index d04ecf10e4..3c03009d43 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -10,7 +10,6 @@ module MOM_surface_forcing_nuopc use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 7eff4597f3..f28c36b9d2 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra 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 +! 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 @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. 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 +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 774f6a67d2..224e26a051 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ 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 :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> 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, & diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 5f8d5fb20b..a19f022cc7 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra 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 +! 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 @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. 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 +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index b02beca313..c29459aad1 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ 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 :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> 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, & @@ -61,7 +71,6 @@ subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, 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, & diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 73304f7fe8..f87b409694 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -19,8 +19,10 @@ module MOM_coupler_types public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data public :: atmos_ocn_coupler_flux, coupler_type_data_override -public :: ind_flux, ind_alpha, ind_csurf public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +! These are encoding constant parameters that indicate whether a flux, solubility or +! surface ocean concentration are being set or accessed with an inquiry. +public :: ind_flux, ind_alpha, ind_csurf !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1ed89ec47e..7fb2580906 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -41,7 +41,6 @@ module MOM_diag_mediator public set_axes_info, post_data, register_diag_field, time_type public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v public set_masks_for_axes -public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 00c42727e1..a97ae52e35 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -10,14 +10,14 @@ module MOM_domains use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain 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, pass_vector, fill_symmetric_edges 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 use MOM_domain_infra, only : start_group_pass, complete_group_pass 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 : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL @@ -54,9 +54,6 @@ module MOM_domains 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 diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 5a125d5abd..3bc16a6aff 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -12,8 +12,9 @@ module MOM_horizontal_regridding use MOM_error_handler, only : MOM_get_verbosity 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, horiz_interp_init -use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type +use MOM_interpolate, only : time_interp_external +use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights +use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data @@ -410,7 +411,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, allocate(tr_in(is:ie,js:je), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -708,7 +709,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else jdp = jd endif - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 4a931d0bf3..8f20bf73fe 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -6,15 +6,15 @@ 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=>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 +use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init +use MOM_interp_infra, only : horiz_interp_type, get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_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, run_horiz_interp, build_horiz_interp_weights +public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. interface time_interp_external diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 8928d2e56b..61ed23b268 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -21,7 +21,6 @@ module MOM_io 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 : stdout_if_root 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 @@ -587,6 +586,11 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim end subroutine reopen_file +!> Return the index of sdtout if called from the root PE, or 0 for other PEs. +integer function stdout_if_root() + stdout_if_root = 0 + if (is_root_PE()) stdout_if_root = stdout +end function stdout_if_root !> This function determines how many time levels a variable has in a file. function num_timelevels(filename, varname, min_dims) result(n_time) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 55e4593dc4..7304688d32 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -25,7 +25,6 @@ module MOM_thickness_diffuse #include public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end -! public vert_fill_TS public thickness_diffuse_get_KH ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7b180f1d65..cc240dfa95 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -81,7 +81,6 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init -! public legacy_diabatic ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with From d8bc9639e806ada7c4a583418de723c20a4a6205 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 11 Apr 2022 16:02:12 -0400 Subject: [PATCH 142/155] Removal of non-standard extensions This patch removes any non-standard compiler extensions from the source and replaces them with equivalent standard statements. Specifically, this allows the code to be compiled with GCC using the -std=f2018 flag. None of these changes impact GFDL testing, since all extensions were supported by GNU, Intel, and PGI, but at least offer some greater assurance that the code will compile and behave more predicably on as-yet untested platforms. The specific changes are outlined below: * `loc() == 0` tests have been replaced with `associated()` where appropriate. (If field is not a pointer then it was removed, since using loc() was already a very bad idea.) * the `dfloat()` type conversion was replaced with `real()`. For consistency with existing MOM code, the `kind` remains unspecified. Technically this could represent an answer change, but was only applied to nz, which is always a very small integer. * `abort()` is an extension, and is replaced with the compliant (and admittedly platform-dependent) `error stop` statement. --- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 3 --- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 4 ++-- src/user/dumbbell_initialization.F90 | 2 +- src/user/seamount_initialization.F90 | 2 +- 6 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bda0b2df38..39ceccaf49 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1741,7 +1741,7 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) endif enddo if (m==0) then - call abort() + error stop endif ! Process first word which will start with the fieldname diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ef71d9286c..22c0ddf8de 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -234,9 +234,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 - if (loc(CS)==0) call MOM_error(FATAL, & - "calculate_diagnostic_fields: Module must be initialized before used.") - if (.not. CS%initialized) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 3d2b322759..f3d77d2ef3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -174,7 +174,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") - if (LOC(Reg)==0) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") if (Reg%ntr == 0 .or. (CS%KhTr <= 0.0 .and. .not. VarMix%use_variable_mixing)) return diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 7386a008e6..b0601e2165 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -232,7 +232,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -574,7 +574,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / dfloat(nz)) + h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / real(nz)) enddo ; enddo case default diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 20beebc67f..2bc2533de5 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -198,7 +198,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 3dba7bfe59..a112737248 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -181,7 +181,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select From d729c679a9f3c83c2b9bab3f8573ee9ef9626573 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 Apr 2022 06:46:00 -0400 Subject: [PATCH 143/155] +Remove append_substring Removed the unused and unnecessary function append_substring. All answers are bitwise identical, but an unused public interface is being eliminated. --- src/framework/MOM_string_functions.F90 | 29 -------------------------- 1 file changed, 29 deletions(-) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index ddc1b41290..5c04a77b7d 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -17,7 +17,6 @@ module MOM_string_functions public extract_real public remove_spaces public slasher -public append_substring contains @@ -419,34 +418,6 @@ function slasher(dir) endif end function slasher -!> append a string (substring) to another string (string_in) and return the -!! concatenated string (string_out) -function append_substring(string_in, substring) result(string_out) - character(len=*), intent(in) :: string_in !< input string - character(len=*), intent(in) :: substring !< string to append string_in - ! local - character(len=1024) :: string_out - character(len=1024) :: string_joined - integer :: string_in_length - integer :: substring_length - - string_out = '' - string_joined = '' - string_in_length = 0 - substring_length = 0 - - string_in_length = len_trim(string_in) - substring_length = len_trim(substring) - - if (string_in_length > 0) then - if (substring_length > 0) then - string_joined = trim(string_in)//trim(substring) - string_out(1:len_trim(string_joined)) = trim(string_joined) - endif - endif - -end function append_substring - !> \namespace mom_string_functions !! !! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. From f54338ad1493a25d304ff48943d234843bc3f48c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Apr 2022 15:45:52 -0400 Subject: [PATCH 144/155] Fix non-standard white space (#109) * Fix non-standard white space Made widespread corrections to indentation and other white space issues to conform to the MOM6 standards, as documented in the white space section of the MOM6 style guide, at https://github.com/mom-ocean/MOM6/wiki/Code-style-guide. - MOM6 code uses a 2-point indent scheme. - There should be a space around all assignment (" = ") operators. - The names of optional arguments do not use whitespace, to differentiate them from assignments. - There is a space around the semicolons for stacked enddo statements. After this change, greping for '^ [a-zA-Z]', '^ [a-zA-Z]' or '^ [a-zA-Z]' does not find any lines in the MOM6 src or config_src/infra code. All answers and output are bitwise identical. --- .../infra/FMS1/MOM_diag_manager_infra.F90 | 60 +-- config_src/infra/FMS1/MOM_domain_infra.F90 | 16 +- .../infra/FMS2/MOM_diag_manager_infra.F90 | 60 +-- config_src/infra/FMS2/MOM_domain_infra.F90 | 16 +- src/ALE/MOM_ALE.F90 | 2 +- src/ALE/MOM_hybgen_remap.F90 | 2 +- src/ALE/MOM_remapping.F90 | 2 +- src/core/MOM.F90 | 2 +- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 4 +- src/core/MOM_dynamics_unsplit.F90 | 4 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 +- src/core/MOM_forcing_type.F90 | 14 +- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/equation_of_state/MOM_EOS_NEMO.F90 | 4 +- src/equation_of_state/MOM_TFreeze.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 2 +- src/framework/MOM_domains.F90 | 2 +- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 20 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 198 ++++----- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 342 +++++++------- .../MOM_state_initialization.F90 | 28 +- src/ocean_data_assim/MOM_oda_incupd.F90 | 420 +++++++++--------- .../vertical/MOM_ALE_sponge.F90 | 6 +- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_ddiff.F90 | 2 +- .../vertical/MOM_CVMix_shear.F90 | 4 +- .../vertical/MOM_bkgnd_mixing.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 2 +- src/tracer/MOM_OCMIP2_CFC.F90 | 10 +- src/tracer/MOM_generic_tracer.F90 | 192 ++++---- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 +- src/tracer/MOM_neutral_diffusion.F90 | 4 +- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 2 +- src/user/dumbbell_surface_forcing.F90 | 2 +- 38 files changed, 726 insertions(+), 728 deletions(-) diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 18c80cf24c..69d82b7d85 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> 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 + 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 diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index f28c36b9d2..249453f42b 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1906,14 +1906,14 @@ 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 + 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 diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 18c80cf24c..69d82b7d85 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> 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 + 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 diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index a19f022cc7..d845d7317b 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1905,14 +1905,14 @@ 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 + 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 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 876c2c684b..e5666a5157 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -334,7 +334,7 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'm', conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', & - 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) end subroutine ALE_register_diags diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 539c992283..59974afad1 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -192,7 +192,7 @@ subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k,i)-s(k-1,i)) * & ( h01_h112(K) - h23_h122(K) ) & + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) - ar(k-1) = al(k) + ar(k-1) = al(k) enddo !k ar(nk-1) = s(nk,i) ! last layer PCM al(nk) = s(nk,i) ! last layer PCM diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index ebe0f81743..4146237e21 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -205,7 +205,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value !! calculations in the same units as h0 [H] - logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for + logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. ! Local variables diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0703e45696..db08802cca 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1908,7 +1908,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & - do_not_log = .true., default=.true. ) + do_not_log=.true., default=.true.) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & "If true, barotropic and baroclinic dynamics, thermodynamics "//& diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3b5c812ba1..d4e365f688 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3053,7 +3053,7 @@ end subroutine apply_velocity_OBCs !! boundary conditions, as developed by Mehmet Ilicak. subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) - type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. + type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index d177e63be8..9f13268090 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1330,10 +1330,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 085b4e02c3..e23a2c4ca1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -694,10 +694,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 91aaca508e..8c855d3aec 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -656,10 +656,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 6de46f7738..9fe449e726 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -265,15 +265,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(), & !< Surface Stokes drift, zonal [m s-1] - vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] + ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] + vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] real, pointer, dimension(:) :: & - stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] real, pointer, dimension(:,:,:) :: & - ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] !! Horizontal - u points !! 3rd dimension - wavenumber - vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] + vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] !! Horizontal - v points !! 3rd dimension - wavenumber @@ -1503,14 +1503,14 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_field_name='ave_evs', cmor_standard_name='water_evaporation_flux_area_averaged', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Averaged') - handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& + handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& long_name='Area integrated liquid precip into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='rainfall_flux_area_averaged', & cmor_field_name='ave_pr', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Averaged') - handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & + handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & long_name='Area integrated frozen precip into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux_area_averaged', & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 39ceccaf49..971fd7e8ee 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1630,7 +1630,7 @@ end subroutine parse_segment_data_str !> Parse all the OBC_SEGMENT_%%%_DATA strings again !! to see which need tracer reservoirs (all pes need to know). - subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) +subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: use_temperature !< If true, T and S are used diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 22c0ddf8de..9c22ab5eb5 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -452,7 +452,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! area mean SSS if (CS%id_sosga > 0) then do j=js,je ; do i=is,ie - surface_field(i,j) = tv%S(i,j,1) + surface_field(i,j) = tv%S(i,j,1) enddo ; enddo sosga = global_area_mean(surface_field, G) call post_data(CS%id_sosga, sosga, CS%diag) diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 68488881bb..b8c2ec2601 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -259,7 +259,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re rho(j) = ( zn + zr0 ) ! density endif - enddo + enddo end subroutine calculate_density_array_nemo !> For a given thermodynamic state, calculate the derivatives of density with conservative @@ -391,7 +391,7 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - enddo + enddo end subroutine calculate_compress_nemo end module MOM_EOS_NEMO diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index 50233cae60..f0b22c8f4e 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -165,7 +165,7 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) - enddo + enddo end subroutine calculate_TFreeze_teos10_array diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 7fb2580906..be8ccd774b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2234,7 +2234,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time ! Register the native diagnostic if (associated(axes_d2)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & 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, & diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index a97ae52e35..47ac43df06 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -182,7 +182,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ "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.) + !$ "If True, use hyper-threading.", default=.false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) !$ endif # endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 3bc16a6aff..1889c59469 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -249,7 +249,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") endif - enddo ; enddo + enddo ; enddo end subroutine fill_miss_2d diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5db9198a22..5b63851b8e 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -327,8 +327,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ISS => CS%ISS if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then - call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & - scale=US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & + scale=US%kg_m2s_to_RZ_T) endif if (CS%rotate_index) then @@ -741,13 +741,13 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) scale=US%RZ_to_kg_m2) endif - call change_thickness_using_precip(CS, ISS, G, US, fluxes,US%s_to_T*time_step, Time) + call change_thickness_using_precip(CS, ISS, G, US, fluxes, US%s_to_T*time_step, Time) - if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) - call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) - endif + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif endif @@ -2136,8 +2136,8 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_ endif if (present(data_override_shelf_fluxes)) then - data_override_shelf_fluxes=.false. - if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes + data_override_shelf_fluxes=.false. + if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes endif end subroutine ice_shelf_query diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e1ecd45347..979517d227 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -540,31 +540,31 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif ! initialize basal friction coefficients - if (new_sim) then - call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) - call pass_var(CS%C_basal_friction, G%domain) - - ! initialize ice-stiffness AGlen - call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) - - !initialize boundary conditions - call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & - CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & - CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) - call pass_var(ISS%hmask, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) - - !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file - call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ground_frac, & - G, US, param_file) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%bed_elev, G%domain,CENTER) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) - endif + if (new_sim) then + call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) + call pass_var(CS%C_basal_friction, G%domain) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain) + + !initialize boundary conditions + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & + CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) + call pass_var(ISS%hmask, G%domain) + call pass_var(CS%h_bdry_val, G%domain) + call pass_var(CS%thickness_bdry_val, G%domain) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + + !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & + G, US, param_file) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + call pass_var(CS%bed_elev, G%domain,CENTER) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif ! Register diagnostics. CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) @@ -628,7 +628,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) enddo enddo - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current @@ -691,58 +691,58 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! - call ice_shelf_advect(CS, ISS, G, time_step, Time) - CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. - - if (coupled_GL) then - call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) - elseif (update_ice_vel) then - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - endif - - - if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) - endif - -! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - - if (update_ice_vel) then - call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) -! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) - call post_data(CS%id_taudx_shelf,taud_x , CS%diag) - endif - if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) - call post_data(CS%id_taudy_shelf,taud_y , CS%diag) - endif - if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) - if (CS%id_visc_shelf > 0) then - ice_visc(:,:)=CS%ice_visc(:,:)*G%IareaT(:,:) - call post_data(CS%id_visc_shelf, ice_visc,CS%diag) - endif - if (CS%id_taub > 0) then - basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) - call post_data(CS%id_taub, basal_tr,CS%diag) - endif + call ice_shelf_advect(CS, ISS, G, time_step, Time) + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) + elseif (update_ice_vel) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif + + + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + endif + +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) + + if (update_ice_vel) then + call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) +! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) + if (CS%id_taudx_shelf > 0) then + taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) + call post_data(CS%id_taudx_shelf, taud_x, CS%diag) + endif + if (CS%id_taudy_shelf > 0) then + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) + call post_data(CS%id_taudy_shelf, taud_y, CS%diag) + endif + if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) + if (CS%id_visc_shelf > 0) then + ice_visc(:,:) = CS%ice_visc(:,:)*G%IareaT(:,:) + call post_data(CS%id_visc_shelf, ice_visc, CS%diag) + endif + if (CS%id_taub > 0) then + basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) + call post_data(CS%id_taub, basal_tr, CS%diag) + endif !! - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) - if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) -! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask, CS%vmask, CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask, CS%u_face_mask_bdry, CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask, CS%v_face_mask_bdry, CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) - call disable_averaging(CS%diag) + call disable_averaging(CS%diag) - CS%elapsed_velocity_time = 0.0 - endif + CS%elapsed_velocity_time = 0.0 + endif end subroutine update_ice_shelf @@ -836,7 +836,7 @@ end subroutine ice_shelf_advect !>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity !subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) - subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -948,7 +948,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied ! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -1001,8 +1001,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1371,7 +1371,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - if (conv_flag == 0) then + if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1859,8 +1859,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - call pass_var(S, G%domain) - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + call pass_var(S, G%domain) + allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) do j=jscq,jecq ; do i=iscq,iecq call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo @@ -2011,7 +2011,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - deallocate(Phi) + deallocate(Phi) end subroutine calc_shelf_driving_stress subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) @@ -2616,11 +2616,10 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:)=1e22 ! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) - do j=jsc,jec - do i=isc,iec + do j=jsc,jec ; do i=isc,iec - if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) do iq=1,2 ; do jq=1,2 @@ -2643,13 +2642,12 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - enddo ; enddo -! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + enddo ; enddo +! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - endif - enddo - enddo + endif + enddo ; enddo deallocate(Phi) end subroutine calc_shelf_visc @@ -2863,16 +2861,16 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - if (J>1) then + if (J>1) then a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) - else - a= G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) - endif - if (I>1) then + else + a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) + endif + if (I>1) then d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) - else + else d = G%dyCu(I,j) !* xquad(qpoint) - endif + endif ! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) ! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index d3202a9f2a..7bd3b45b2a 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -277,120 +277,120 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b thickness_bdry_val, hmask, h_shelf, G,& US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - - real, dimension(SZIB_(G),SZJ_(G)), & - intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - - real, dimension(SZI_(G),SZJB_(G)), & - intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters - - character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. - integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed - real :: input_thick ! The input ice shelf thickness [Z ~> m] - real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] - real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - - - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & - "inflow ice velocity at upstream boundary", & - units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? - call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & - "flux thickness at upstream boundary", & - units="m", default=1000., scale=US%m_to_Z) - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & - "maximum position of no-flow condition in along-flow direction", & - units="km", default=0.) - - call MOM_mesg(mdl//": setting boundary") - - isd = G%isd ; ied = G%ied - jsd = G%jsd ; jed = G%jed - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - !---------b.c.s based on geopositions ----------------- - do j=jsc,jec+1 - do i=isc-1,iec+1 - ! upstream boundary - set either dirichlet or flux condition - - if (G%geoLonBu(i,j) == westlon) then - hmask(i+1,j) = 3.0 - h_bdry_val(i+1,j) = h_shelf(i+1,j) - thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) - u_face_mask_bdry(i+1,j) = 3.0 - u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution - endif - - - ! side boundaries: no flow - if (G%geoLatBu(i,j-1) == southlat) then !bot boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j+1) = 0. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - else - v_face_mask_bdry(i,j+1) = 1. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - endif - elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j-1) = 0. - u_face_mask_bdry(i,j-1) = 3. - else - v_face_mask_bdry(i,j-1) = 3. - u_face_mask_bdry(i,j-1) = 3. - endif - endif - - ! downstream boundary - CFBC - if (G%geoLonBu(i,j) == westlon+lenlon) then - u_face_mask_bdry(i-1,j) = 2.0 - endif - - enddo - enddo + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. + integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + real :: input_thick ! The input ice shelf thickness [Z ~> m] + real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] + real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises + + + call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & + "inflow ice velocity at upstream boundary", & + units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? + call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & + "flux thickness at upstream boundary", & + units="m", default=1000., scale=US%m_to_Z) + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & + "maximum position of no-flow condition in along-flow direction", & + units="km", default=0.) + + call MOM_mesg(mdl//": setting boundary") + + isd = G%isd ; ied = G%ied + jsd = G%jsd ; jed = G%jed + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + !---------b.c.s based on geopositions ----------------- + do j=jsc,jec+1 + do i=isc-1,iec+1 + ! upstream boundary - set either dirichlet or flux condition + + if (G%geoLonBu(i,j) == westlon) then + hmask(i+1,j) = 3.0 + h_bdry_val(i+1,j) = h_shelf(i+1,j) + thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + u_face_mask_bdry(i+1,j) = 3.0 + u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! side boundaries: no flow + if (G%geoLatBu(i,j-1) == southlat) then !bot boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j+1) = 0. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + else + v_face_mask_bdry(i,j+1) = 1. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + endif + elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j-1) = 0. + u_face_mask_bdry(i,j-1) = 3. + else + v_face_mask_bdry(i,j-1) = 3. + u_face_mask_bdry(i,j-1) = 3. + endif + endif + + ! downstream boundary - CFBC + if (G%geoLonBu(i,j) == westlon+lenlon) then + u_face_mask_bdry(i-1,j) = 2.0 + endif + + enddo + enddo end subroutine initialize_ice_shelf_boundary_channel @@ -400,10 +400,10 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice @@ -471,33 +471,33 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & hmask, h_shelf, G, US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: umask !< A mask for ice shelf velocity [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: umask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & @@ -562,10 +562,10 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask do j=jsc,jec do i=isc,iec - if (hmask(i,j) == 3.) then - thickness_bdry_val(i,j) = h_shelf(i,j) - h_bdry_val(i,j) = h_shelf(i,j) - endif + if (hmask(i,j) == 3.) then + thickness_bdry_val(i,j) = h_shelf(i,j) + h_bdry_val(i,j) = h_shelf(i,j) + endif enddo enddo @@ -574,8 +574,8 @@ end subroutine initialize_ice_shelf_boundary_from_file !> Initialize ice basal friction subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: C_basal_friction !< Ice-stream basal friction + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-stream basal friction type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -595,19 +595,19 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) - C_basal_friction(:,:) = C_friction + C_basal_friction(:,:) = C_friction elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & - "The file from which basal friction coefficients are read.", & - default="ice_basal_friction.nc") - filename = trim(inputdir)//trim(C_friction_file) - call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which basal friction coefficients are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) - call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & "The variable to use in basal traction.", & default="tau_b_beta") @@ -623,8 +623,8 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) !> Initialize ice basal friction subroutine initialize_ice_AGlen(AGlen, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -644,19 +644,19 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call get_param(PF, mdl, "A_GLEN", A_Glen, & "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) - AGlen(:,:) = A_Glen + AGlen(:,:) = A_Glen elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & "The file from which the ice-stiffness is read.", & default="ice_AGlen.nc") - filename = trim(inputdir)//trim(AGlen_file) - call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) - call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & "The variable to use as ice-stiffness.", & default="A_GLEN") diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ee3052f166..0aeba26e17 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1947,7 +1947,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t "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.) + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) !### NEW_SPONGES should be obsoleted properly, rather than merely deprecated, at which ! point only the else branch of the new_sponge_param block would be retained. @@ -2000,18 +2000,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t 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 + ! 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 @@ -2255,7 +2255,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p "The name of the meridional vel. inc. variable in "//& "ODA_INCUPD_FILE.", default="v_inc") -! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) +! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) ! Read in incremental update for tracers filename = trim(inputdir)//trim(inc_file) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 5f38fa15d0..80c313e488 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -201,13 +201,13 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! get number of timestep for full update if (nhours_incupd == 0) then - CS%nstep_incupd = 1 !! direct insertion + CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& trim(mesg)) ! number of inc. update already done, CS%ncount, either from restart or set to 0.0 @@ -219,14 +219,14 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re endif write(mesg,'(f4.1)') CS%ncount if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& trim(mesg)) ! get the vertical grid (h_obs) of the increments CS%nz_data = nz_data allocate(CS%Ref_h%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data - CS%Ref_h%p(i,j,k) = data_h(i,j,k) + CS%Ref_h%p(i,j,k) = data_h(i,j,k) enddo; enddo ; enddo !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. @@ -263,7 +263,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%Inc(CS%fldno)%nz_data = CS%nz_data allocate(CS%Inc(CS%fldno)%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do k=1,CS%nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) + CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) enddo ; enddo ; enddo end subroutine set_up_oda_incupd_field @@ -374,122 +374,122 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) ! remap t,s (on h_init) to h_obs to get increment tmp_val1(:) = 0.0 do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) == 1) then + if (G%mask2dT(i,j) == 1) then + ! account for the different SSH + sum_h1 = 0.0 + sum_h2 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + + do k=1,nz_data + sum_h2 = sum_h2+h_obs(i,j,k) + enddo + do k=1,nz_data + tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + enddo + ! get temperature + do k=1,nz + tmp_val1(k) = tv%T(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + enddo + + ! get salinity + do k=1,nz + tmp_val1(k) = tv%S(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + enddo + endif + enddo ; enddo + + ! remap u to h_obs to get increment + if (CS%uv_inc) then + call pass_var(h, G%Domain) + + hu(:) = 0.0 + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + ! get u-velocity + do k=1,nz + tmp_val1(k) = u(i,j,k) + ! get the h and h_obs at u points + hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) + enddo + do k=1,nz_data + hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) + enddo ! account for the different SSH sum_h1 = 0.0 - sum_h2 = 0.0 do k=1,nz - sum_h1 = sum_h1+h(i,j,k) + sum_h1 = sum_h1+hu(k) enddo - + sum_h2 = 0.0 do k=1,nz_data - sum_h2 = sum_h2+h_obs(i,j,k) + sum_h2 = sum_h2+hu_obs(k) enddo do k=1,nz_data - tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) enddo - ! get temperature - do k=1,nz - tmp_val1(k) = tv%T(i,j,k) - enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + ! remap model u on hu_obs + call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & + nz_data, hu_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) enddo - - ! get salinity + endif + enddo ; enddo + + ! remap v to h_obs to get increment + hv(:) = 0.0; + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v-velocity do k=1,nz - tmp_val1(k) = tv%S(i,j,k) + tmp_val1(k) = v(i,j,k) + ! get the h and h_obs at v points + hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + do k=1,nz_data + hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) + enddo + ! account for the different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1+hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2+hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) + enddo + ! remap model v on hv_obs + call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & + nz_data, hv_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) enddo - endif - enddo; enddo - - ! remap u to h_obs to get increment - if (CS%uv_inc) then - call pass_var(h, G%Domain) - - hu(:) = 0.0 - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - ! get u-velocity - do k=1,nz - tmp_val1(k) = u(i,j,k) - ! get the h and h_obs at u points - hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) - enddo - do k=1,nz_data - hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) - enddo - ! remap model u on hu_obs - call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & - nz_data, hu_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo - - ! remap v to h_obs to get increment - hv(:) = 0.0; - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v-velocity - do k=1,nz - tmp_val1(k) = v(i,j,k) - ! get the h and h_obs at v points - hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) - enddo - do k=1,nz_data - hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) - enddo - ! remap model v on hv_obs - call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & - nz_data, hv_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo + endif + enddo ; enddo endif ! uv_inc call pass_var(CS%Inc(1)%p, G%Domain) @@ -603,118 +603,118 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k) enddo if (G%mask2dT(i,j) == 1) then - ! get temperature increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(1)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - do k=1,nz - ! add increment to tracer on model h - tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) - tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics - enddo - - ! get salinity increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(2)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - ! add increment to tracer on model h - do k=1,nz - tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) - tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics - ! bound salinity values ! check if it is correct to do that or if it hides - ! other problems ... - tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) - enddo + ! get temperature increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(1)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + do k=1,nz + ! add increment to tracer on model h + tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) + tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics + enddo + + ! get salinity increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(2)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + ! add increment to tracer on model h + do k=1,nz + tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) + tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics + ! bound salinity values ! check if it is correct to do that or if it hides + ! other problems ... + tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) + enddo endif - enddo; enddo + enddo ; enddo ! add u and v increments if (CS%uv_inc) then - call pass_var(h,G%Domain) ! to ensure reproducibility - - ! add increments to u - hu(:) = 0.0 - tmp_u(:,:,:) = 0.0 ! diagnostics - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - do k=1,nz_data - ! get u increment - tmp_val2(k) = CS%Inc_u%p(i,j,k) - ! get the h and h_obs at u points - hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) - enddo - do k=1,nz - hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=( sum_h1 / sum_h2 ) * hu_obs(k) - enddo - ! remap increment profile on hu - call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & - nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to u-velocity on hu - do k=1,nz - u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_u(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo - - ! add increments to v - hv(:) = 0.0 - tmp_v(:,:,:) = 0.0 ! diagnostics - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v increment - do k=1,nz_data - tmp_val2(k) = CS%Inc_v%p(i,j,k) - ! get the h and h_obs at v points - hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) - enddo - do k=1,nz - hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) - enddo - ! remap increment profile on hv - call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & - nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to v-velocity on hv - do k=1,nz - v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_v(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo + call pass_var(h,G%Domain) ! to ensure reproducibility + + ! add increments to u + hu(:) = 0.0 + tmp_u(:,:,:) = 0.0 ! diagnostics + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + do k=1,nz_data + ! get u increment + tmp_val2(k) = CS%Inc_u%p(i,j,k) + ! get the h and h_obs at u points + hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) + enddo + do k=1,nz + hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hu(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hu_obs(k) + enddo + do k=1,nz_data + hu_obs(k) = ( sum_h1 / sum_h2 ) * hu_obs(k) + enddo + ! remap increment profile on hu + call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & + nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to u-velocity on hu + do k=1,nz + u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_u(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo + + ! add increments to v + hv(:) = 0.0 + tmp_v(:,:,:) = 0.0 ! diagnostics + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v increment + do k=1,nz_data + tmp_val2(k) = CS%Inc_v%p(i,j,k) + ! get the h and h_obs at v points + hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) + enddo + do k=1,nz + hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) + enddo + ! remap increment profile on hv + call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & + nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to v-velocity on hv + do k=1,nz + v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_v(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo endif ! uv_inc diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 446cdb8b45..10b46f7e7d 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -275,15 +275,15 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! u points CS%num_col_u = 0 ; if (present(Iresttime_u_in)) then - Iresttime_u(:,:) = Iresttime_u_in(:,:) + Iresttime_u(:,:) = Iresttime_u_in(:,:) else do j=G%jsc,G%jec ; do I=G%iscB,G%iecB Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & - CS%num_col_u = CS%num_col_u + 1 + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & + CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 7371ba7009..58d6e3417a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -293,7 +293,7 @@ end subroutine calculate_CVMix_conv logical function CVMix_conv_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_conv_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index f1ac4c926a..aca84f59e2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -274,7 +274,7 @@ end subroutine compute_ddiff_coeffs logical function CVMix_ddiff_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_ddiff_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index eed99ceb3f..db98e063d8 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -326,9 +326,9 @@ logical function CVMix_shear_is_used(param_file) ! Local variables logical :: LMD94, PP81 call get_param(param_file, mdl, "USE_LMD94", LMD94, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "Use_PP81", PP81, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index c3ee727573..fb218a7d67 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -523,7 +523,7 @@ end subroutine calculate_bkgnd_mixing logical function CVMix_bkgnd_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_BACKGROUND", CVMix_bkgnd_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_bkgnd_is_used diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index cc240dfa95..8f82dce3c9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3370,7 +3370,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & 'Boundary forcing heat tendency', & - 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive = .true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 28a9501d51..2928a0c718 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -288,14 +288,14 @@ 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) = atmos_ocn_coupler_flux('cfc_11_flux', & - flux_type = 'air_sea_gas_flux', implementation='ocmip2', & + 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) 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 /), & + 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) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 5e8632f1ca..65947fc64c 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -129,8 +129,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Register all the generic tracers used and create the list of them. !This can be called by ALL PE's. No array fields allocated. if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. + call generic_tracer_register() + g_registered = .true. endif @@ -188,29 +188,29 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) g_tracer=>CS%g_tracer_list do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? - tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) then - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false., & !### CHANGE TO TRUE? - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - else - call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & - restart_CS, longname=longname, units=units) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + call g_tracer_get_alias(g_tracer,g_tracer_name) + + call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) + call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) + call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) + + !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? + tr_ptr => tr_field(:,:,:,1) + ! Register prognastic tracer for horizontal advection, diffusion, and restarts. + if (g_tracer_is_prog(g_tracer)) then + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=g_tracer_name, longname=longname, units=units, & + registry_diags=.false., & !### CHANGE TO TRUE? + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + else + call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & + restart_CS, longname=longname, units=units) + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer=>g_tracer_next enddo @@ -281,70 +281,70 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - if (g_tracer%requires_src_info ) then - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initializing generic tracer "//trim(g_tracer_name)//& - " using MOM_initialize_tracer_from_Z ") - - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = g_tracer%src_file, & - src_var_nam = g_tracer%src_var_name, & - src_var_unit_conversion = g_tracer%src_var_unit_conversion,& - src_var_record = g_tracer%src_var_record, & - src_var_gridspec = g_tracer%src_var_gridspec ) - - !Check/apply the bounds for each g_tracer - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min - !Jasmin does not want to apply the maximum for now - !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max - endif - enddo ; enddo ; enddo - - !jgj: Reset CASED to 0 below K=1 - if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then - do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - tr_ptr(i,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - elseif(.not. g_tracer%requires_restart) then + if (g_tracer%requires_src_info ) then + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initializing generic tracer "//trim(g_tracer_name)//& + " using MOM_initialize_tracer_from_Z ") + + call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & + src_file = g_tracer%src_file, & + src_var_nam = g_tracer%src_var_name, & + src_var_unit_conversion = g_tracer%src_var_unit_conversion,& + src_var_record = g_tracer%src_var_record, & + src_var_gridspec = g_tracer%src_var_gridspec ) + + !Check/apply the bounds for each g_tracer + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + !Jasmin does not want to apply the maximum for now + !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + endif + enddo ; enddo ; enddo + + !jgj: Reset CASED to 0 below K=1 + if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then + do k=2,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + tr_ptr(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + endif + elseif(.not. g_tracer%requires_restart) then !Do nothing for this tracer, it is initialized by the tracer package call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& "skip initialization of generic tracer "//trim(g_tracer_name)) - else !Do it old way if the tracer is not registered to start from a specific source file. + else !Do it old way if the tracer is not registered to start from a specific source file. !This path should be deprecated if all generic tracers are required to start from specified sources. - if (len_trim(CS%IC_file) > 0) then - ! Read the tracer concentrations from a netcdf 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, GV, US) - if (.not.OK) then - 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)//".") + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf 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, GV, US) + if (.not.OK) then + 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)//".") + endif + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initialized generic tracer "//trim(g_tracer_name)//& + " using Generic Tracer File on Z: "//CS%IC_file) + else + ! native grid + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) + call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) endif - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initialized generic tracer "//trim(g_tracer_name)//& - " using Generic Tracer File on Z: "//CS%IC_file) else - ! native grid - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) + call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& + "check Generic Tracer IC filename "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) endif - else - call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - endif - endif + endif endif !traverse the linked list till hit NULL @@ -459,21 +459,21 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (_ALLOCATED(g_tracer%trunoff)) then - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) - !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) - stf_array = stf_array + runoff_tracer_flux_array - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + if (_ALLOCATED(g_tracer%trunoff)) then + call g_tracer_get_alias(g_tracer,g_tracer_name) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) + !nnz: Why is fluxes%river = 0? + runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & + US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) + stf_array = stf_array + runoff_tracer_flux_array + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer => g_tracer_next enddo diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 7296640560..8efb341ec3 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -126,7 +126,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., answers_2018 = .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.", & @@ -382,9 +382,9 @@ subroutine unique(val, n, val_unique, val_max) max_val = MAXVAL(val) i = 0 do while (min_valmin_val) - tmp(i) = min_val + i = i+1 + min_val = MINVAL(val, mask=val>min_val) + tmp(i) = min_val enddo ii = i if (limit) then @@ -745,8 +745,8 @@ logical function near_boundary_unit_tests( verbose ) 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 initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& + check_reconstruction=.true., check_remapping=.true.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 08361ba9af..7f1f39bbc0 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -167,11 +167,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& - "boundary layers.", default = .false.) + "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.) + "recommended.", default=.false.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index f3d77d2ef3..5012cc4d66 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1498,7 +1498,7 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_File, mdl, "RECALC_NEUTRAL_SURF", CS%recalc_neutral_surf, & "If true, then recalculate the neutral surfaces if the \n"//& "diffusive CFL is exceeded. If false, assume that the \n"//& - "positions of the surfaces do not change \n", default = .false.) + "positions of the surfaces do not change \n", default=.false.) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6214f2d095..64fb31f68d 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -223,7 +223,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 8c980edc8e..54985e35fc 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -228,7 +228,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& From f6fc6ce170586a25d28697576ad162c58ad29778 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 13 Apr 2022 17:14:50 -0400 Subject: [PATCH 145/155] FMS2: get_field_sizes with FMS1 emulation This patch modifies the `get_field_sizes` function to emulate the FMS1 behavior when the requested `sizes(:)` is larger than the field's number of dimensions. In FMS1, `field_sizes` would always expect a `sizes` array of at least size 4, and in the format of (nx, ny, nz, nt), and would lean on netCDF attributes like `cartesian_axes` when assigning the values. FMS2 lacks similar functionality, due its more general approach. Previously, this was emulated in a way favorable to certain situations, but raised issues in others. This patch attempts to resolve the issue by using the `categorize_axes()` function's ability to identify axes, either by attributes, presumed names, or the `unlimited` property. --- config_src/infra/FMS2/MOM_io_infra.F90 | 66 ++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 10 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 16b7e45bc6..eb616dffa3 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -609,11 +609,14 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) !! names with an appended tile number ! Local variables type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information - ! about the exiting time axis entries in append mode. + ! about the exiting time axis entries in append mode. logical :: success ! If true, the file was opened successfully logical :: field_exists ! True if filename exists and field_name is in filename integer :: i, ndims - + character(len=512), allocatable :: dimnames(:) ! Field dimension names + logical, allocatable :: is_x(:), is_y(:), is_t(:) ! True if index matches axis type + integer :: size_indices(4) ! Mapping of size index to FMS1 convention + integer :: idx, swap if (FMS2_reads) then field_exists = .false. @@ -626,12 +629,53 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) if (ndims > size(sizes)) call MOM_error(FATAL, & "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo - ! This preserves previous behavior when reading time-varying data without - ! a vertical extent. - if (size(sizes)==ndims+1) then - sizes(ndims+1)=sizes(ndims) - sizes(ndims)=1 + + ! If sizes exceeds ndims, then we fallback to the FMS1 convention + ! where sizes has at least 4 dimension, and try to position values. + if (size(sizes) > ndims) then + ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) + if (size(sizes) < 4) & + call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& + &"then its length must be at least 4.") + + ! Fall back to the FMS1 default values of 1 (from mpp field%size) + sizes(ndims+1:) = 1 + + ! Gather the field dimension names + allocate(dimnames(ndims)) + dimnames(:) = "" + call get_variable_dimension_names(fileObj_read, trim(fieldname), & + dimnames) + + ! Test the dimensions against standard (x,y,t) names and attributes + allocate(is_x(ndims), is_y(ndims), is_t(ndims)) + is_x(:) = .false. + is_y(:) = .false. + is_t(:) = .false. + call categorize_axes(fileObj_read, filename, ndims, dimnames, & + is_x, is_y, is_t) + + ! Currently no z-test is supported, so disable assignment with 0 + size_indices = [ & + findloc(is_x, .true.), & + findloc(is_y, .true.), & + 0, & + findloc(is_t, .true.) & + ] + + do i = 1, size(size_indices) + idx = size_indices(i) + if (idx > 0) then + swap = sizes(i) + sizes(i) = sizes(idx) + sizes(idx) = swap + endif + enddo + + deallocate(is_x, is_y, is_t) + deallocate(dimnames) endif endif endif @@ -1483,7 +1527,7 @@ end subroutine MOM_register_variable_axes !> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other !! unlimited dimensions are also labeled as time axes for these purposes. subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) - type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + class(FmsNetcdfFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object character(len=*), intent(in) :: filename !< The name of the file to read integer, intent(in) :: ndims !< The number of dimensions associated with a variable character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable @@ -1530,8 +1574,10 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if (.not.(x_found .and. y_found)) then ! Look for hints from CF-compliant axis units for uncharacterized axes do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then - call get_variable_units(fileobj, trim(dim_names(i)), units) - call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (variable_exists(fileobj, trim(dim_names(i)))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + endif if (is_x(i)) x_found = .true. if (is_y(i)) y_found = .true. endif ; enddo From 684878ee40507c5a40f436a0b5f86fdcf8977d75 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 19 Apr 2022 14:24:27 -0700 Subject: [PATCH 146/155] Add a deta_dt diagnostic to the split BT/BC mode (#99) * Add a deta_dt diagnostic to the split BT/BC mode The SSH tendency can now be computed for the split baroclinic/ bartropic (integrated with RK2) way of calculating the dynamics. This extra diagnostic is needed for computing vertical mass transport (wmo) in z* coordinates offline from the convergence of the horizontal mass transports. The meaning, units, and conversion factors associated with the deta_dt diagnostic change between Boussinesq and non-Boussinesq modes. This commit accounts for these differences and reports the units consistent with the mass transports. (A. Shao gets the credit for the substance of this commit.) --- src/core/MOM_dynamics_split_RK2.F90 | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 9f13268090..21c9702ca0 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -177,6 +177,7 @@ module MOM_dynamics_split_RK2 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 @@ -315,6 +316,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: eta_pred + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! eta_pred is the predictor value of the free surface height or column mass, ! [H ~> m or kg m-2]. @@ -347,6 +349,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: Idt_bc ! Inverse of the baroclinic timestep logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the @@ -357,10 +360,13 @@ 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 = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + Idt_bc = 1./dt + sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums showCallTree = callTree_showQuery() @@ -760,6 +766,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + endif do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo call cpu_clock_end(id_clock_btstep) @@ -958,6 +967,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_v_BT_accel_visc_rem > 0) & call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1334,6 +1346,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & x_cell_method='sum', v_extensive=.true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & From 48ae48ae7baec1a6d1a5127594066b964de97928 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 13 Apr 2022 10:20:03 -0400 Subject: [PATCH 147/155] Remove unused variables This patch removes any unused variables detected by -Wunused-variables in GCC. This may include variables which are referenced in commented "zombie code". In some cases, the variables were preserved in comments, but not in all cases. If the zombie code is restored, it should be possible to reconstruct the original declaration. (All known cases were simple scalars, such as loop indices). In one case, a variable was conditionally used within a preprocessor `#ifdef __DO_SAFETY_CHECKS__` block. This patch moves the declaration into another `#ifdef` block, but perhaps it is preferable to remove the block. Certain documentation variables such as `mdl`, which typically contain the function name, have been removed if unused. The strongest motivation for this patch is to allow us to enable the `-Wall` flag, which includes unused variables, and will strengthen our ability to detect potential errors in the codebase. --- .../solo_driver/MESO_surface_forcing.F90 | 2 - config_src/drivers/solo_driver/MOM_driver.F90 | 1 - .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 2 - .../infra/FMS1/MOM_couplertype_infra.F90 | 2 - config_src/infra/FMS1/MOM_domain_infra.F90 | 10 ++-- config_src/infra/FMS1/MOM_io_infra.F90 | 3 +- src/ALE/MOM_ALE.F90 | 3 +- src/ALE/MOM_hybgen_regrid.F90 | 7 +-- src/ALE/MOM_hybgen_remap.F90 | 1 - src/ALE/MOM_hybgen_unmix.F90 | 3 -- src/ALE/MOM_regridding.F90 | 21 +++++--- src/ALE/MOM_remapping.F90 | 6 +-- src/ALE/PLM_functions.F90 | 6 +-- src/ALE/coord_slight.F90 | 4 +- src/ALE/regrid_edge_values.F90 | 16 +++--- src/ALE/regrid_interp.F90 | 1 - src/ALE/regrid_solvers.F90 | 1 - src/core/MOM.F90 | 24 +++------ src/core/MOM_CoriolisAdv.F90 | 9 +--- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- src/core/MOM_barotropic.F90 | 13 +---- src/core/MOM_continuity_PPM.F90 | 2 - src/core/MOM_density_integrals.F90 | 6 +-- src/core/MOM_dynamics_split_RK2.F90 | 1 - src/core/MOM_dynamics_unsplit.F90 | 3 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- src/core/MOM_forcing_type.F90 | 12 ++--- src/core/MOM_grid.F90 | 2 +- src/core/MOM_isopycnal_slopes.F90 | 5 +- src/core/MOM_open_boundary.F90 | 31 +++-------- src/core/MOM_porous_barriers.F90 | 2 +- src/core/MOM_variables.F90 | 3 +- src/diagnostics/MOM_debugging.F90 | 2 +- src/diagnostics/MOM_obsolete_diagnostics.F90 | 2 - src/diagnostics/MOM_obsolete_params.F90 | 4 +- src/diagnostics/MOM_sum_output.F90 | 16 +----- src/diagnostics/MOM_wave_speed.F90 | 6 +-- src/diagnostics/MOM_wave_structure.F90 | 5 +- src/equation_of_state/MOM_EOS.F90 | 9 +--- src/equation_of_state/MOM_EOS_NEMO.F90 | 8 +-- src/equation_of_state/MOM_EOS_Wright.F90 | 2 +- src/equation_of_state/MOM_EOS_linear.F90 | 2 - src/framework/MOM_checksums.F90 | 1 - src/framework/MOM_coms.F90 | 4 +- src/framework/MOM_diag_mediator.F90 | 22 ++++---- src/framework/MOM_diag_remap.F90 | 17 +++---- src/framework/MOM_diag_vkernels.F90 | 7 +-- src/framework/MOM_document.F90 | 2 - src/framework/MOM_dyn_horgrid.F90 | 3 -- src/framework/MOM_error_handler.F90 | 2 - src/framework/MOM_file_parser.F90 | 8 +-- src/framework/MOM_horizontal_regridding.F90 | 15 ++---- src/framework/MOM_io.F90 | 9 +--- src/framework/MOM_random.F90 | 2 +- src/framework/MOM_restart.F90 | 8 +-- src/framework/MOM_string_functions.F90 | 2 - src/framework/MOM_write_cputime.F90 | 1 - src/ice_shelf/MOM_ice_shelf.F90 | 20 +++----- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 6 +-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 51 +++++++------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 12 ++--- src/ice_shelf/user_shelf_init.F90 | 5 -- .../MOM_coord_initialization.F90 | 2 +- src/initialization/MOM_grid_initialize.F90 | 9 +--- .../MOM_shared_initialization.F90 | 6 +-- .../MOM_state_initialization.F90 | 48 ++++++++--------- .../MOM_tracer_initialization_from_Z.F90 | 2 - src/ocean_data_assim/MOM_oda_driver.F90 | 36 +++---------- src/ocean_data_assim/MOM_oda_incupd.F90 | 5 +- src/parameterizations/lateral/MOM_MEKE.F90 | 4 +- .../lateral/MOM_hor_visc.F90 | 28 ++-------- .../lateral/MOM_internal_tides.F90 | 30 ++++------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 6 +-- .../lateral/MOM_thickness_diffuse.F90 | 1 - .../lateral/MOM_tidal_forcing.F90 | 2 - .../stochastic/MOM_stochastics.F90 | 1 - .../vertical/MOM_ALE_sponge.F90 | 31 ++--------- .../vertical/MOM_CVMix_KPP.F90 | 11 ++-- .../vertical/MOM_CVMix_ddiff.F90 | 1 - .../vertical/MOM_bulk_mixed_layer.F90 | 6 +-- .../vertical/MOM_diabatic_aux.F90 | 8 ++- .../vertical/MOM_diabatic_driver.F90 | 23 ++------- .../vertical/MOM_diapyc_energy_req.F90 | 18 ++----- .../vertical/MOM_energetic_PBL.F90 | 3 +- .../vertical/MOM_geothermal.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 5 +- .../vertical/MOM_kappa_shear.F90 | 6 +-- .../vertical/MOM_opacity.F90 | 6 +-- .../vertical/MOM_regularize_layers.F90 | 9 +--- .../vertical/MOM_set_diffusivity.F90 | 3 +- .../vertical/MOM_set_viscosity.F90 | 5 +- src/parameterizations/vertical/MOM_sponge.F90 | 1 - .../vertical/MOM_tidal_mixing.F90 | 2 - .../vertical/MOM_vert_friction.F90 | 1 - src/tracer/DOME_tracer.F90 | 12 ----- src/tracer/ISOMIP_tracer.F90 | 13 ----- src/tracer/MOM_CFC_cap.F90 | 11 ++-- src/tracer/MOM_OCMIP2_CFC.F90 | 7 ++- src/tracer/MOM_generic_tracer.F90 | 9 +--- src/tracer/MOM_lateral_boundary_diffusion.F90 | 15 +++--- src/tracer/MOM_neutral_diffusion.F90 | 37 ++++---------- src/tracer/MOM_offline_aux.F90 | 18 +++---- src/tracer/MOM_offline_main.F90 | 20 +++----- src/tracer/MOM_tracer_Z_init.F90 | 16 ++---- src/tracer/MOM_tracer_advect.F90 | 8 --- src/tracer/MOM_tracer_diabatic.F90 | 2 +- src/tracer/MOM_tracer_flow_control.F90 | 4 +- src/tracer/MOM_tracer_hor_diff.F90 | 3 -- src/tracer/MOM_tracer_registry.F90 | 1 - src/tracer/RGC_tracer.F90 | 10 ---- src/tracer/advection_test_tracer.F90 | 17 +------ src/tracer/boundary_impulse_tracer.F90 | 16 +----- src/tracer/dye_example.F90 | 12 ----- src/tracer/dyed_obc_tracer.F90 | 12 ----- src/tracer/ideal_age_example.F90 | 10 +--- src/tracer/nw2_tracers.F90 | 4 -- src/tracer/oil_tracer.F90 | 7 +-- src/tracer/tracer_example.F90 | 8 +-- src/user/DOME2d_initialization.F90 | 3 +- src/user/DOME_initialization.F90 | 3 -- src/user/ISOMIP_initialization.F90 | 18 +++---- src/user/Kelvin_initialization.F90 | 1 - src/user/MOM_wave_interface.F90 | 8 +-- src/user/Neverworld_initialization.F90 | 5 +- src/user/Phillips_initialization.F90 | 2 +- src/user/RGC_initialization.F90 | 2 +- src/user/Rossby_front_2d_initialization.F90 | 6 +-- src/user/adjustment_initialization.F90 | 3 +- src/user/basin_builder.F90 | 1 - src/user/benchmark_initialization.F90 | 1 - src/user/circle_obcs_initialization.F90 | 2 +- src/user/dumbbell_initialization.F90 | 17 +++---- src/user/dumbbell_surface_forcing.F90 | 4 +- src/user/dyed_channel_initialization.F90 | 8 +-- src/user/dyed_obcs_initialization.F90 | 3 +- src/user/lock_exchange_initialization.F90 | 3 -- src/user/seamount_initialization.F90 | 2 +- src/user/shelfwave_initialization.F90 | 5 +- src/user/sloshing_initialization.F90 | 4 +- src/user/soliton_initialization.F90 | 1 - src/user/tidal_bay_initialization.F90 | 3 +- src/user/user_change_diffusivity.F90 | 6 --- 142 files changed, 315 insertions(+), 850 deletions(-) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 9c67be4829..fa1d7f5701 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -77,8 +77,6 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index c2cd0a248c..f076b7c5a4 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -129,7 +129,6 @@ program MOM_main ! representation of dt_forcing. real :: dt_forcing ! The coupling time step [s]. real :: dt ! The nominal baroclinic dynamics time step [s]. - real :: dt_off ! Offline time step [s]. integer :: ntstep ! The number of baroclinic dynamics time steps ! within dt_forcing. real :: dt_therm ! The thermodynamic timestep [s] diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index de513a7f11..cbc310eb7d 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -185,7 +185,6 @@ subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,posi integer, optional, intent(in) :: ntau !< Unknown logical, optional, intent(in) :: positive !< Unknown real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown - integer :: tau character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' end subroutine g_tracer_get_3D_val @@ -257,7 +256,6 @@ end subroutine g_tracer_set_real subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node type(time_type), intent(in) :: model_time !< Time integer, intent(in) :: tau !< The time step for the %field 4D field to be reported end subroutine g_tracer_send_diag diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index 3bcccc1dc7..637f2b5ebf 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -409,8 +409,6 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & !! 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 diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 249453f42b..470dde0848 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -241,8 +241,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner ! 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 :: isc, iec, jsc, jec, isd, ied, jsd, jed + integer :: i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn integer :: dirflag logical :: block_til_complete @@ -593,7 +593,6 @@ subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scal 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 @@ -1328,10 +1327,8 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l !! 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 logical :: mask_table_exists ! Mask_table is present and the file it points to exists @@ -1516,7 +1513,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain 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. @@ -1819,7 +1815,7 @@ subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) integer, optional, intent(out) :: jed !< The end j-index of the data domain ! Local variables - integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + integer :: isd_, ied_, jsd_, jed_ call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index f956f9fa51..c0ccfcbcc8 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -715,9 +715,8 @@ subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data, file_is_global + logical :: file_is_global integer :: n, unit, ndim, nvar, natt, ntime - integer :: is, ie, js, je ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are ! needed. diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e5666a5157..b3eb39157f 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -162,7 +162,6 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) type(ALE_CS), pointer :: CS !< Module control structure ! Local variables - real, allocatable :: dz(:) character(len=40) :: mdl = "MOM_ALE" ! This module's name. character(len=80) :: string, vel_string ! Temporary strings real :: filter_shallow_depth, filter_deep_depth @@ -1427,7 +1426,7 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness [H ~> m or kg m-2] ! Local variables - integer :: i, j, k + integer :: i, j do j = G%jsd,G%jed ; do i = G%isd,G%ied h(i,j,:) = GV%Z_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 783820829f..22fd474854 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -386,7 +386,7 @@ subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) ! each target layer, in the unusual case where the the input grid is ! larger than the new grid. This situation only occurs during certain ! types of initialization or when generating output diagnostics. - integer :: i, j, k, nk, m, k2, nk_in + integer :: i, j, k, nk, k2, nk_in nk = CS%nk @@ -532,8 +532,6 @@ subroutine hybgen_column_init(nk, nsigma, dp0k, ds0k, dp00i, topiso_i_j, & ! --- -------------------------------------------------------------- ! Local variables - character(len=256) :: mesg ! A string for output messages - real :: hybrlx ! The relaxation rate in the hybrid region [timestep-1]? real :: qdep ! Total water column thickness as a fraction of dp0k (vs ds0k) [nondim] real :: q ! A portion of the thickness that contributes to the new cell [H ~> m or kg m-2] real :: p_int(nk+1) ! Interface depths [H ~> m or kg m-2] @@ -641,8 +639,6 @@ real function cushn(delp, dp0) real, intent(in) :: delp ! A thickness change [H ~> m or kg m-2] real, intent(in) :: dp0 ! A non-negative reference thickness [H ~> m or kg m-2] - real :: qq ! A limited ratio of delp/dp0 [nondim] - ! These are the nondimensional parameters that define the cushion function. real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] ! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] @@ -705,7 +701,6 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & real :: h_hat0 ! A first guess at thickness movement upward across the interface ! between layers k and k-1 [H ~> m or kg m-2] real :: dh_cor ! Thickness changes [H ~> m or kg m-2] - real :: h1_tgt ! A target thickness for the top layer [H ~> m or kg m-2] real :: tenm ! ten m in pressure units [H ~> m or kg m-2] real :: onemm ! one mm in pressure units [H ~> m or kg m-2] logical :: trap_errors diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 59974afad1..213c6c677e 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -267,7 +267,6 @@ subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] - real :: ds2a, ds2b ! Squared tracer differences between a cell average and the edge values [A2] logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are ! very thin, or because this is specified by PCM_lay. real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 index 6e204f856b..a2b94d846b 100644 --- a/src/ALE/MOM_hybgen_unmix.F90 +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -59,8 +59,6 @@ subroutine init_hybgen_unmix(CS, GV, US, param_file, hybgen_regridCS) type(param_file_type), intent(in) :: param_file !< Parameter file type(hybgen_regrid_CS), pointer :: hybgen_regridCS !< Control structure for hybgen !! regridding for sharing parameters. - - character(len=40) :: mdl = "MOM_hybgen" ! This module's name. integer :: k if (associated(CS)) call MOM_error(FATAL, "init_hybgen_unmix: CS already associated!") @@ -315,7 +313,6 @@ subroutine hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, eqn_of_state, & ! used for updating the concentration of passive tracers [nondim] real :: swap_T ! A swap variable for temperature [degC] real :: swap_S ! A swap variable for salinity [ppt] - real :: swap_R ! A swap variable for the coordinate potential density [R ~> kg m-3] real :: swap_tr ! A temporary swap variable for the tracers [conc] logical, parameter :: lunmix=.true. ! unmix a too light deepest layer integer :: k, ka, kp, kt, m diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 78159146a2..95a77f503d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -202,10 +202,10 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings - logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters + logical :: tmpLogical, fix_haloclines, do_sum, main_parameters logical :: coord_is_state_dependent, ierr logical :: default_2018_answers, remap_answers_2018 - real :: filt_len, strat_tol, index_scale, tmpReal, P_Ref + real :: filt_len, strat_tol, tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha @@ -1152,7 +1152,10 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. ! Local variables - real :: nominalDepth, minThickness, totalThickness, dh ! Depths and thicknesses [H ~> m or kg m-2] + real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! [H ~> m or kg m-2] +#endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] integer :: i, j, k, nz @@ -1165,7 +1168,10 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & !$OMP ice_shelf,minThickness) & !$OMP private(nominalDepth,totalThickness, & -!$OMP zNew,dh,zOld) +#ifdef __DO_SAFETY_CHECKS__ +!$OMP dh, & +#endif +!$OMP zNew,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1257,7 +1263,10 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) ! Local variables integer :: i, j, k integer :: nz - real :: nominalDepth, totalThickness, dh + real :: nominalDepth, totalThickness +#ifdef __DO_SAFETY_CHECKS__ + real :: dh +#endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] @@ -1503,7 +1512,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] integer :: i, j, k, nki - real :: depth, nominalDepth + real :: nominalDepth real :: h_neglect, h_neglect_edge real :: z_top_col, totalThickness logical :: ice_shelf diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 4146237e21..50e1085cf6 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -213,8 +213,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial - real :: edges(n0,2) ! Interpolation edge values [A] - real :: slope(n0) ! Interpolation slopes per cell width [A] real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] @@ -298,7 +296,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k - real :: eps, h0tot, h0err, h1tot, h1err + real :: h0tot, h0err, h1tot, h1err real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real, dimension(n1) :: h1 !< Cell widths on target grid real :: hNeglect, hNeglect_edge @@ -389,8 +387,6 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ! Local variables integer :: local_remapping_scheme - integer :: remapping_scheme !< Remapping scheme - logical :: boundary_extrapolation !< Extrapolate at boundaries if true integer :: k, n ! Reset polynomial diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index d0f620e4a8..9defeb9215 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -197,11 +197,9 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) ! Local variables integer :: k ! loop index - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths + real :: u_l, u_r ! left and right cell averages real :: slope ! retained PLM slope - real :: a, b ! auxiliary variables - real :: u_min, u_max, e_l, e_r, edge + real :: e_r, edge real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 23a390456e..66c78d7c7a 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -235,13 +235,11 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. - real :: k2_used, k2here, dz_sum, z_max - integer :: k2 real :: h_tr, b_denom_1, b1, d1 ! Temporary variables used by the tridiagonal solver. real, dimension(nz) :: c1 ! Temporary variables used by the tridiagonal solver. integer :: kur1, kur2 ! The indicies at the top and bottom of an unreliable region. integer :: kur_ss ! The index to start with in the search for the next unstable region. - integer :: i, j, k, nkml + integer :: k, nkml maximum_depths_set = allocated(CS%max_interface_depths) maximum_h_set = allocated(CS%max_layer_thickness) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 2baac56599..a972fc3444 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -229,7 +229,6 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables real :: h0, h1, h2, h3 ! temporary thicknesses [H] - real :: h_sum ! A sum of adjacent thicknesses [H] real :: h_min ! A minimal cell width [H] real :: f1, f2, f3 ! auxiliary variables with various units real :: et1, et2, et3 ! terms the expresson for edge values [A H] @@ -240,7 +239,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Difference of successive values of x [H] real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. @@ -394,9 +393,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j ! loop indexes - real :: h0, h1, h2 ! cell widths [H] + real :: h0, h1 ! cell widths [H] real :: h_min ! A minimal cell width [H] - real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 real :: h0ph1_2, h0ph1_4 real :: alpha, beta ! stencil coefficients [nondim] @@ -407,7 +405,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, parameter :: C1_3 = 1.0 / 3.0 real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] @@ -569,7 +567,6 @@ subroutine end_value_h4(dz, u, Csys) real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] real, parameter :: C1_3 = 1.0 / 3.0 - integer :: i, j, k ! These are only used for code verification ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. @@ -706,7 +703,6 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real :: h0, h1 ! cell widths [H or nondim] real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] - real :: h_min ! A minimal cell width [H] real :: d ! A temporary variable [H3] real :: I_d ! A temporary variable [nondim] real :: I_h ! Inverses of thicknesses [H-1] @@ -716,7 +712,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! matrix used to find boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(3) :: Dsys @@ -927,7 +923,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) real :: h_Min_Frac = 1.0e-4 - integer :: i, j, k ! loop indexes + integer :: i, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -1162,7 +1158,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - integer :: i, j, k ! loop indexes + integer :: i, k ! loop indexes hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 87019d46cf..21773774f6 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -283,7 +283,6 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - logical :: use_2018_answers ! If true use older, less acccurate expressions. integer :: k ! loop index real :: t ! current interface target density diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 50bd7f984d..b7cc3b5402 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -119,7 +119,6 @@ subroutine linear_solver( N, A, R, X ) real :: factor ! The factor that eliminates the leading nonzero element in a row. real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] real :: swap - logical :: found_pivot ! If true, a pivot has been found integer :: i, j, k ! Loop on rows to transform the problem into multiplication by an upper-right matrix. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index db08802cca..c4f3d40343 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -508,10 +508,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! if it is not to be calculated anew [T ~> s]. real :: rel_time = 0.0 ! relative time since start of this call [T ~> s]. - logical :: calc_dtbt ! Indicates whether the dynamically adjusted - ! barotropic time step needs to be updated. logical :: do_advection ! If true, it is time to advect tracers. - logical :: do_calc_bbl ! If true, calculate the boundary layer properties. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. @@ -533,7 +530,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS p_surf => NULL() ! A pointer to the ocean surface pressure [R L2 T-2 ~> Pa]. real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] - type(time_type) :: Time_local, end_time_thermo, Time_temp + type(time_type) :: Time_local, end_time_thermo type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree @@ -966,7 +963,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (cycle_end) then if (CS%rotate_index) then allocate(sfc_state_diag) - call rotate_surface_state(sfc_state, G_in, sfc_state_diag, G, turns) + call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) else sfc_state_diag => sfc_state endif @@ -1050,7 +1047,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! barotropic time step needs to be updated. logical :: showCallTree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights @@ -1331,7 +1328,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer :: halo_sz ! The size of a halo where data must be valid. - integer :: i, j, k, is, ie, js, je, nz + integer :: is, ie, js, je, nz real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights !! for porous topo. [Z ~> m or 1/eta_to_m] @@ -1532,11 +1529,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS real :: dt_offline ! The offline timestep for advection [T ~> s] real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] logical :: skip_diffusion - integer :: id_eta_diff_end type(time_type), pointer :: accumulated_time => NULL() type(time_type), pointer :: vertical_time => NULL() - integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed ! 3D pointers @@ -1762,20 +1757,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This include declares and sets the variable "version". # include "version_variable.h" - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB real :: dtbt ! If negative, this specifies the barotropic timestep as a fraction ! of the maximum stable value [nondim]. real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: area_shelf_in ! area occupied by ice shelf [L2 ~> m2] -! real, dimension(:,:), pointer :: shelf_area => NULL() - type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. - logical :: ensemble_ocean ! If true, perform an ensemble gather at the end of step_MOM logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. @@ -1816,12 +1807,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors - character(len=48) :: flux_units, S_flux_units + character(len=48) :: S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state - character(len=200) :: area_varname, ice_shelf_file, inputdir, filename CS%Time => Time @@ -3587,7 +3577,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then - call rotate_surface_state(sfc_state, G, sfc_state_in, G_in, -turns) + call rotate_surface_state(sfc_state, sfc_state_in, G_in, -turns) call deallocate_surface_state(sfc_state) endif diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 19f14ceac3..c1dfd500dc 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -178,11 +178,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. - q2, & ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. - max_fvq, & ! The maximum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. - 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]. + q2 ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. 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]. @@ -193,9 +189,6 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) real, parameter :: C1_12=1.0/12.0 ! C1_12 = 1/12 real, parameter :: C1_24=1.0/24.0 ! C1_24 = 1/24 - real :: absolute_vorticity ! Absolute vorticity [T-1 ~> s-1]. - real :: relative_vorticity ! Relative vorticity [T-1 ~> s-1]. - real :: Ih ! Inverse of thickness [H-1 ~> m-1 or m2 kg-1]. real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells ! surrounding a q point [H L2 ~> m3 or kg]. diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 18ea07b313..7d20409453 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -831,7 +831,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables - logical :: use_temperature, use_EOS + logical :: use_EOS ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d4e365f688..fac76d1aef 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2776,7 +2776,6 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) logical :: use_BT_cont type(memory_size_type) :: MS - character(len=200) :: mesg integer :: i, j, k, is, ie, js, je, nz if (.not.CS%module_is_initialized) call MOM_error(FATAL, & @@ -3086,10 +3085,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. - integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq + integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw - logical :: OBC_used 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 @@ -3306,7 +3304,6 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: wt_arith ! The weight for the arithmetic mean thickness [nondim]. ! The harmonic mean uses a weight of (1 - wt_arith). - real :: Rh ! A ratio of summed thicknesses [nondim] real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2] real :: e_v(SZI_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2] real :: D_shallow_u(SZI_(G)) ! The height of the shallower of the adjacent bathymetric depths @@ -3622,8 +3619,6 @@ function uhbt_to_ubt(uhbt, BTC) result(ubt) real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -3757,8 +3752,6 @@ function vhbt_to_vbt(vhbt, BTC) result(vbt) real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -4295,8 +4288,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! name in wave_drag_file. real :: vel_rescale ! A rescaling factor for horizontal velocity from the representation in ! a restart file to the internal representation in this run. - real :: uH_rescale ! A rescaling factor for thickness transports from the representation in - ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real :: det_de ! The partial derivative due to self-attraction and loading of the reference @@ -4309,7 +4300,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: apply_bt_drag, use_BT_cont_type + logical :: use_BT_cont_type character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index e5bd2f9ae9..402a6921ae 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -269,7 +269,6 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple - type(OBC_segment_type), pointer :: segment => NULL() use_visc_rem = present(visc_rem_u) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. @@ -1097,7 +1096,6 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC - type(OBC_segment_type), pointer :: segment => NULL() use_visc_rem = present(visc_rem_v) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8f26918253..4b7ba9454a 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -143,7 +143,6 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] @@ -1726,7 +1725,7 @@ end subroutine find_depth_of_pressure_in_cell !> Returns change in anomalous pressure change from top to non-dimensional -!! position pos between z_t and z_b +!! position pos between z_t and z_b [R L2 T-2 ~> Pa] real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) real, intent(in) :: T_t !< Potential temperature at the cell top [degC] real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] @@ -1739,8 +1738,7 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: dz ! Distance from the layer top [Z ~> m] diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 21c9702ca0..6482fc40fd 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -997,7 +997,6 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] type(vardesc) :: vd(2) - character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index e23a2c4ca1..a7517ccc4f 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -536,7 +536,6 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by !! initialize_dyn_unsplit. - character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -619,7 +618,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" logical :: use_tides diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 8c855d3aec..9acb2b5c83 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -566,7 +566,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" logical :: use_tides diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9fe449e726..227623f5eb 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1985,8 +1985,8 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) ! applied based on the time interval stored in flux_tmp. real :: wt1 ! The relative weight of the previous fluxes [nondim] - 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 :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB 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 @@ -2284,7 +2284,7 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) type(diag_ctrl), intent(inout) :: diag !< diagnostic type type(forcing_diags), intent(inout) :: handles !< diagnostic id for diag_manager - integer :: i,j,is,ie,js,je + integer :: is, ie, js, je type(mech_forcing), pointer :: forces integer :: turns @@ -2958,7 +2958,6 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water logical :: shelf_sfc_acc isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3096,7 +3095,6 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -3565,12 +3563,8 @@ subroutine homogenize_forcing(fluxes, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real :: avg ! Global average of a variable, in the same units as that variable logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy - integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index d9ed8ffee4..f73fcc33af 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -207,7 +207,7 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Local variables real :: mean_SeaLev_scale ! A scaling factor for the reference height variable [1] or [Z m-1 ~> 1] - integer :: isd, ied, jsd, jed, nk + integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: ied_max, jed_max integer :: niblock, njblock, nihalo, njhalo, nblocks, n, i, j diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index acd31c2091..38a3544703 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -98,7 +98,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. - real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. @@ -219,7 +218,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,slope2_Ratio,l_seg) + !$OMP drdx,mag_grad2,slope,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -329,7 +328,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,slope2_Ratio,l_seg) + !$OMP drdy,mag_grad2,slope,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 971fd7e8ee..c2afe5c2b5 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -357,7 +357,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - character(len=128) :: inputdir logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=64) :: remappingScheme @@ -651,7 +650,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir @@ -1640,11 +1639,10 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=256) :: mesg ! Message for error messages. do n=1, OBC%number_of_segments segment => OBC%segment(n) @@ -3490,7 +3488,6 @@ subroutine allocate_OBC_segment_data(OBC, segment) integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: IscB, IecB, JscB, JecB - character(len=40) :: mdl = "allocate_OBC_segment_data" ! This subroutine's name. isd = segment%HI%isd ; ied = segment%HI%ied jsd = segment%HI%jsd ; jed = segment%HI%jed @@ -3576,8 +3573,6 @@ end subroutine allocate_OBC_segment_data !> Deallocate segment data fields subroutine deallocate_OBC_segment_data(segment) type(OBC_segment_type), intent(inout) :: segment !< Open boundary segment - ! Local variables - character(len=40) :: mdl = "deallocate_OBC_segment_data" ! This subroutine's name. if (.not. segment%on_pe) return @@ -3709,14 +3704,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! Local variables integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB, n, m, nz - character(len=40) :: mdl = "update_OBC_segment_data" ! This subroutine's name. - character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] integer :: ni_seg, nj_seg ! number of src gridpoints along the segments integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer - integer :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] @@ -4413,7 +4405,6 @@ subroutine OBC_registry_init(param_file, Reg) integer, save :: init_calls = 0 # include "version_variable.h" - character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. character(len=256) :: mesg ! Message for error messages. if (.not.associated(Reg)) then ; allocate(Reg) @@ -4472,7 +4463,7 @@ subroutine segment_tracer_registry_init(param_file, segment) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. - character(len=256) :: mesg ! Message for error messages. + !character(len=256) :: mesg ! Message for error messages. if (.not.associated(segment%tr_Reg)) then allocate(segment%tr_Reg) @@ -4579,11 +4570,10 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf - integer :: i, j, k, n - character(len=32) :: name + integer :: n + character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - type(tracer_type), pointer :: tr_ptr => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() if (.not. associated(OBC)) return @@ -4675,14 +4665,12 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j integer :: l_seg logical :: fatal_error = .False. real :: min_depth ! The minimum depth for ocean points [Z ~> m] integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 character(len=256) :: mesg ! Message for error messages. - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, ! two different ways @@ -4922,9 +4910,8 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables type(vardesc) :: vd(2) - integer :: m, n + integer :: m character(len=100) :: mesg, var_name - type(OBC_segment_type), pointer :: segment=>NULL() if (.not. associated(OBC)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& @@ -5112,11 +5099,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) integer, intent(in) :: fld !< field index to adjust thickness integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - integer :: n real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m] real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] ! real :: dilate ! A factor by which to dilate the water column [nondim] - character(len=100) :: mesg + !character(len=100) :: mesg hTolerance = 0.1*US%m_to_Z @@ -5450,7 +5436,6 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) integer, intent(in) :: turns integer :: n - integer :: is, ie, js, je, nk integer :: num_fields diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index d23509d5f6..e807f19484 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -48,7 +48,7 @@ subroutine por_widths(h, tv, G, GV, US, eta, pbv, eta_bt, halo_size, eta_to_m) type(porous_barrier_ptrs), intent(inout) :: pbv !< porous barrier fractional cell metrics !local variables - integer ii, i, j, k, nk, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer i, j, k, nk, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real w_layer, & ! fractional open width of layer interface [nondim] A_layer, & ! integral of fractional open width from bottom to current layer[Z ~> m] A_layer_prev, & ! integral of fractional open width from bottom to previous layer [Z ~> m] diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a9bf6c3dcf..7cdf3e8e71 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -441,9 +441,8 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. -subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) +subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) type(surface), intent(in) :: sfc_state_in - type(ocean_grid_type), intent(in) :: G_in type(surface), intent(inout) :: sfc_state type(ocean_grid_type), intent(in) :: G integer, intent(in) :: turns diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 3b24a3871b..fd7e891e82 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -435,7 +435,7 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch - integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed + integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed is_ch = G%isc ; ie_ch = G%iec ; js_ch = G%jsc ; je_ch = G%jec diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 86034292b5..ddfe0452a0 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -64,8 +64,6 @@ 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) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 27c9b988ee..e0441cac2e 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -23,8 +23,8 @@ subroutine find_obsolete_params(param_file) character(len=40) :: mdl = "find_obsolete_params" ! This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" - integer :: test_int, l_seg, nseg - logical :: test_logic, test_logic2, test_logic3, split + integer :: l_seg, nseg + logical :: test_logic, split character(len=40) :: temp_string if (.not.is_root_pe()) return diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 48097b40c4..33f3edcfd4 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -348,16 +348,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: Salt_anom ! The change in salt that cannot be accounted for by ! the surface fluxes [ppt kg]. real :: salin ! The mean salinity of the ocean [ppt]. - real :: salin_chg ! The change in total salt since the last call - ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by ! the surface fluxes divided by total mass [ppt]. real :: Heat ! The total amount of Heat in the ocean [J]. real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [J]. real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [J]. real :: temp ! The mean potential temperature of the ocean [degC]. - real :: temp_chg ! The change in total heat divided by total heat capacity - ! of the ocean since the last call to this subroutine, degC. real :: temp_anom ! The change in total heat that cannot be accounted for ! by the surface fluxes, divided by the total heat ! capacity of the ocean [degC]. @@ -397,7 +393,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> 1] 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 :: i, j, k, is, ie, js, je, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer 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. @@ -936,12 +932,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! over a time step [ppt kg]. heat_in ! The total heat added by surface fluxes, integrated ! over a time step [J]. - real :: FW_input ! The net fresh water input, integrated over a timestep - ! and summed over space [kg]. - real :: salt_input ! The total salt added by surface fluxes, integrated - ! over a time step and summed over space [ppt kg]. - real :: heat_input ! The total heat added by boundary fluxes, integrated - ! over a time step and summed over space [J]. real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] @@ -953,7 +943,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in_EFP ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. - real :: inputs(3) ! A mixed array for combining the sums integer :: i, j, is, ie, js, je, isr, ier, jsr, jer is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1287,8 +1276,7 @@ subroutine read_depth_list(G, US, DL, filename, require_chksum, file_matches) ! Local variables character(len=240) :: var_msg - real, allocatable :: tmp(:) - integer :: ncid, list_size, k, ndim, sizes(4) + integer :: list_size, ndim, sizes(4) 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 diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 50933abe07..9cb7c46c37 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -103,7 +103,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] - real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 + real :: det, ddet real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] @@ -207,7 +207,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & !$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & -!$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) +!$OMP det,ddet,det_it,ddet_it) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can @@ -722,7 +722,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging integer :: sub, sub_it - integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 81c8799828..931532983a 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -128,8 +128,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Hc, & !< A column of layer thicknesses after convective instabilities are removed [Z ~> m] Tc, & !< A column of layer temperatures after convective instabilities are removed [degC] Sc, & !< A column of layer salinites after convective instabilities are removed [ppt] - Rc, & !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] - det, ddet + Rc !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G)) :: & htot !< The vertical sum of the thicknesses [Z ~> m] real :: lam !< inverse of wave speed squared [T2 L-2 ~> s2 m-2] @@ -141,7 +140,6 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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, parameter :: tol1 = 0.0001, tol2 = 0.001 @@ -613,7 +611,6 @@ subroutine tridiag_solver(a, b, c, h, y, method, x) ! intermediate values for solvers real :: Q_prime, beta ! intermediate values for solver integer :: k ! row (e.g. interface) index - integer :: i,j nrow = size(y) allocate(c_prime(nrow)) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 39b626985a..80a8d3f866 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -769,7 +769,6 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - integer :: j p_scale = EOS%RL2_T2_to_Pa @@ -947,7 +946,6 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start type(EOS_type), intent(in) :: EOS !< Equation of state structure ! Local variables - real, dimension(size(T)) :: press ! Pressure converted to [Pa] real, dimension(size(T)) :: rho ! In situ density [kg m-3] real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] @@ -1160,10 +1158,6 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - ! Local variables - real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical ! integration be used instead of analytic. This is a safety check. @@ -1453,8 +1447,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure integer :: i, j, k - real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp - real :: p + real :: gsw_sr_from_sp, gsw_ct_from_pt if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index b8c2ec2601..476fda6b70 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -184,8 +184,6 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) real, intent(out) :: rho !< In situ density [kg m-3]. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real :: al0, p0, lambda - integer :: j real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -212,7 +210,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: zp, zt, zh, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 + real :: zp, zt, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 integer :: j do j=start,start+npts-1 @@ -276,7 +274,7 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zp,zt , zh , zs , zr0, zn , zn0, zn1, zn2, zn3 + real :: zp, zt, zs, zn, zn0, zn1, zn2, zn3 integer :: j do j=start,start+npts-1 @@ -347,8 +345,6 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1]. ! Local variables - real :: al0, p0, lambda - integer :: j real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: drdt0, drds0 diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 730687fbf6..8293cf5d32 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -351,7 +351,7 @@ subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: al0, p0, lambda, I_denom + real :: p0, lambda, I_denom integer :: j do j=start,start+npts-1 diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 5ab2874175..c56c397a8d 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -117,8 +117,6 @@ subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - ! Local variables - integer :: j if (present(spv_ref)) then specvol = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T + dRho_dS*S)) / & diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 15db6abce9..aae3d3f5dc 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -531,7 +531,6 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector - logical :: sym logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 9e4b811a46..8bf1164a70 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -245,11 +245,11 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer(kind=8), dimension(ni) :: ints_sum integer(kind=8) :: prec_error - real :: rsum(1), rs + real :: rsum(1) logical :: repro, do_sum_across_PEs character(len=256) :: mesg type(EFP_type) :: EFP_val ! An extended fixed point version of the sum - integer :: i, j, n, is, ie, js, je + integer :: i, j, is, ie, js, je if (num_PEs() > max_count_prec) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index be8ccd774b..9f6b57fe6c 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -348,7 +348,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Local variables 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 + integer :: i, j, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert real, allocatable, dimension(:) :: IaxB,iax @@ -586,7 +586,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, k, nz, dl + integer :: i, j, nz, dl real, dimension(:), pointer :: gridLonT_dsamp =>NULL() real, dimension(:), pointer :: gridLatT_dsamp =>NULL() real, dimension(:), pointer :: gridLonB_dsamp =>NULL() @@ -754,7 +754,7 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj + integer :: c, nk, i, j, k type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords @@ -852,9 +852,8 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj - integer :: dl - type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + integer :: c, dl + type(axes_grp), pointer :: axes => NULL() ! Current axes, for convenience !Each downsampled axis needs both downsampled and non-downsampled mask !The downsampled mask is needed for sending out the diagnostics output via diag_manager @@ -1377,7 +1376,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o + integer :: isv, iev, jsv, jev, i, j, isv_o,jsv_o real, dimension(:,:), allocatable, target :: locfield_dsamp real, dimension(:,:), allocatable, target :: locmask_dsamp integer :: dl @@ -1522,7 +1521,6 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) ! Local variables type(diag_type), pointer :: diag => null() - integer :: nz, i, j, k real, dimension(:,:,:), allocatable :: remapped_field logical :: staggered_in_x, staggered_in_y real, dimension(:,:,:), pointer :: h_diag => NULL() @@ -1647,7 +1645,6 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) logical :: is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o - integer :: chksum real, dimension(:,:,:), allocatable, target :: locfield_dsamp real, dimension(:,:,:), allocatable, target :: locmask_dsamp integer :: dl @@ -2914,7 +2911,7 @@ function register_static_field(module_name, field_name, axes, & real :: MOM_missing_value type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() - integer :: dm_id, fms_id, cmor_id + integer :: dm_id, fms_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name character(len=9) :: axis_name @@ -3858,7 +3855,7 @@ end subroutine diag_restore_grids subroutine diag_grid_storage_end(grid_storage) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids ! Local variables - integer :: m, nz + integer :: m ! Don't do anything else if there are no remapped coordinates if (grid_storage%num_diag_coords < 1) return @@ -3881,7 +3878,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: i,j,k,ii,jj,dl + integer :: k, dl !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec !print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb @@ -4297,7 +4294,6 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 real :: ave, total_weight, weight - real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_len ! A negligibly small horizontal length [L ~> m] diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index f9e5a35a09..63e6bcba7a 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -189,16 +189,11 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure + ! Local variables - integer :: nzi(4), nzl(4), k - character(len=200) :: inputdir, string, filename, int_varname, layer_varname character(len=40) :: mod = "MOM_diag_remap" ! This module's name. - character(len=8) :: units, expected_units - character(len=34) :: longname, string2 - - character(len=256) :: err_msg - logical :: ierr - + character(len=8) :: units + character(len=34) :: longname real, allocatable, dimension(:) :: interfaces, layers call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & @@ -363,7 +358,7 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing @@ -502,7 +497,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing @@ -582,7 +577,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 24ff07e7d0..886f6dcd4d 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -98,12 +98,11 @@ subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells real, intent(in) :: missing_value !< Value to assign in vanished cells real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces + ! Local variables - real :: x_dest ! Relative position of target interface real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses - real :: uh_src_rem, uh_dest_rem, duh ! Incremental amounts of stuff + real :: uh_src_rem, duh ! Incremental amounts of stuff integer :: k_src, k_dest ! Index of cell in src and dest columns - integer :: iter logical :: src_ran_out, src_exists uh_dest(:) = missing_value @@ -294,7 +293,6 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces integer :: k real :: error - logical :: print_results ! Interpolate from src to dest call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) @@ -333,7 +331,6 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells integer :: k real :: error - logical :: print_results ! Interpolate from src to dest call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 24f77a0eb2..a68a725feb 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -389,7 +389,6 @@ subroutine doc_openBlock(doc, blockName, desc) character(len=*), optional, intent(in) :: desc !< A description of the parameter block being opened ! This subroutine handles documentation for opening a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -413,7 +412,6 @@ subroutine doc_closeBlock(doc, blockName) character(len=*), intent(in) :: blockName !< The name of the parameter block being closed ! This subroutine handles documentation for closing a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring integer :: i if (.not. (is_root_pe() .and. associated(doc))) return diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 8264a903cf..bfc6f1b1a4 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -311,9 +311,6 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: turns !< Number of quarter turns - integer :: jsc, jec, jscB, jecB - integer :: qturn - ! Center point call rotate_array(G_in%geoLonT, turns, G%geoLonT) call rotate_array(G_in%geoLatT, turns, G%geoLatT) diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 223423c7fc..d61e82b32c 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -85,7 +85,6 @@ subroutine disable_fatal_errors(env) type(sigjmp_buf), intent(in) :: env !> Process recovery state after FATAL errors - integer :: rc integer :: sig ignore_fatal = .true. @@ -110,7 +109,6 @@ end subroutine disable_fatal_errors !> Disable the error handler and abort on FATAL subroutine enable_fatal_errors() - integer :: rc integer :: sig procedure(handler_interface), pointer :: dummy diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 853d3c4de4..3a25981dc8 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -136,7 +136,7 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! the documentation files. The default is effectively './'. ! Local variables - logical :: file_exists, unit_in_use, Netcdf_file, may_check, reopened_file + logical :: file_exists, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path type(parameter_block), pointer :: block => NULL() @@ -927,7 +927,7 @@ function max_input_line_length(CS, pf_num) result(max_len) character(len=FILENAME_LENGTH) :: filename character :: last_char integer :: ipf, ipf_s, ipf_e - integer :: last, last1, line_len, count, contBufSize + integer :: last, line_len, count, contBufSize logical :: continuedLine max_len = 0 @@ -1580,7 +1580,7 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & logical :: use_timeunit, date_format character(len=240) :: mesg, myunits character(len=80) :: date_string, default_string - integer :: days, secs, ticks, ticks_per_sec + integer :: days, secs, ticks use_timeunit = .false. date_format = .false. ; if (present(log_date)) date_format = log_date @@ -2021,7 +2021,7 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date !! format. The default is false. - logical :: do_read, do_log, date_format, log_date + logical :: do_read, do_log, log_date do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1889c59469..718f0073ae 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -295,13 +295,13 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid. real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp + integer :: id, jd, kd, jdp integer :: i, j, k - integer, dimension(4) :: start, count, dims, dim_id + integer, dimension(4) :: start, count real, dimension(:,:), allocatable :: x_in, y_in 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 :: max_lat, pole, max_depth, npole real :: roundoff ! The magnitude of roundoff, usually ~2e-16. real :: add_offset, scale_factor logical :: found_attr @@ -311,11 +311,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, type(horiz_interp_type) :: Interp type(axis_info), dimension(4) :: axes_info ! Axis information used for regridding integer :: is, ie, js, je ! compute domain indices - 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 - character(len=12) :: dim_name(4) logical :: debug=.false. real :: npoints, varAvg real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid @@ -618,25 +616,22 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid. real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp + integer :: id, jd, kd, jdp 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 ! 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 :: max_lat, pole, max_depth, npole real :: roundoff ! The magnitude of roundoff, usually ~2e-16. logical :: add_np character(len=8) :: laynum type(horiz_interp_type) :: Interp type(axistype), dimension(4) :: axes_data integer :: is, ie, js, je ! compute domain indices - 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 integer, dimension(4) :: fld_sz - character(len=12) :: dim_name(4) logical :: debug=.false. logical :: spongeDataOngrid logical :: ans_2018 diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 61ed23b268..e8df89b268 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -603,7 +603,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) integer :: n_time !< number of time levels varname has in filename character(len=256) :: msg - integer :: ncid, status, varid, ndims + integer :: ndims integer :: sizes(8) n_time = -1 @@ -926,7 +926,6 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) integer, allocatable :: field_start(:), field_nread(:) integer :: i, rc character(len=*), parameter :: hdr = "read_variable_2d: " - character(len=128) :: msg ! Validate shape of start and nread if (present(start)) then @@ -2108,7 +2107,6 @@ subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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 @@ -2143,7 +2141,6 @@ subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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 @@ -2178,7 +2175,6 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale @@ -2307,7 +2303,7 @@ function ensembler(name, ens_no_in) result(en_nm) character(10) :: ens_num_char character(3) :: code_str integer :: ens_no - integer :: n, is, ie + integer :: n, is en_nm = trim(name) if (index(name,"%") == 0) return @@ -2408,7 +2404,6 @@ subroutine get_var_axes_info(filename, fieldname, axes_info) integer :: ncid, varid, ndims integer :: id, jd, kd integer, dimension(4) :: dims, dim_id - real :: missing_value character(len=128) :: dim_name(4) integer, dimension(1) :: start, count !! cartesian axis data diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index cf649c32f7..fbdc916346 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -192,7 +192,7 @@ integer function seed_from_index(HI, i, j) integer, intent(in) :: i !< i-index (of h-cell) integer, intent(in) :: j !< j-index (of h-cell) ! Local variables - integer :: ig, jg, ni, nj, ij + integer :: ig, jg, ni, nj ni = HI%niglobal nj = HI%njglobal diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index a5386ce7fa..2687b6f8c6 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -949,7 +949,6 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. - character(len=64) :: var_name ! A variable's name. real :: conv ! Shorthand for the conversion factor real :: restart_time character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs @@ -1131,17 +1130,12 @@ subroutine restore_state(filename, directory, day, G, CS) ! Local variables real :: scale ! A scaling factor for reading a field real :: conv ! The output conversion factor for writing a field - character(len=200) :: filepath ! The path (dir/file) to the file being opened. - character(len=80) :: fname ! The name of the current file. - character(len=8) :: suffix ! A suffix (like "_2") that is added to any - ! additional restart files. character(len=512) :: mesg ! A message for warnings. character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. integer :: i, n, m, missing_fields - integer :: isL, ieL, jsL, jeL, is0, js0 - integer :: sizes(7) + integer :: isL, ieL, jsL, jeL integer :: nvar, ntime, pos type(file_type) :: IO_handles(CS%max_fields) ! The I/O units of all open files. diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 5c04a77b7d..65aa864f4e 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -247,7 +247,6 @@ integer function extract_integer(string, separators, n, missing_value) integer, intent(in) :: n !< Number of word to extract integer, optional, intent(in) :: missing_value !< Value to assign if word is missing ! Local variables - integer :: ns, i, b, e, nw character(len=20) :: word word = extract_word(string, separators, n) @@ -271,7 +270,6 @@ real function extract_real(string, separators, n, missing_value) integer, intent(in) :: n !< Number of word to extract real, optional, intent(in) :: missing_value !< Value to assign if word is missing ! Local variables - integer :: ns, i, b, e, nw character(len=20) :: word word = extract_word(string, separators, n) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index cc43ec19ea..5277cef1f6 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -138,7 +138,6 @@ subroutine write_cputime(day, n, CS, nmax, call_end) ! this subroutine. integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK real :: reday ! A real version of day. - character(len=256) :: mesg ! The text of an error message integer :: start_of_day, num_days if (.not.associated(CS)) call MOM_error(FATAL, & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5b63851b8e..10aef884dd 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -312,7 +312,6 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true, the grouding line position is determined based on ! coupled ice-ocean dynamics. - logical :: use_temperature = .true. ! real, parameter :: c2_3 = 2.0/3.0 character(len=160) :: mesg ! The text of an error message @@ -333,7 +332,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (CS%rotate_index) then allocate(sfc_state) - call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state, CS%Grid, CS%turns) + call rotate_surface_state(sfc_state_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) @@ -793,7 +792,7 @@ 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_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) call rotate_forcing(fluxes,fluxes_in,-CS%turns) endif @@ -972,8 +971,7 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) 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 - + integer :: i, j, is, ie, js, je G=>CS%Grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1222,7 +1220,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() - type(dyn_horgrid_type), pointer :: dG_in => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. real :: RZ_rescale ! A rescaling factor for mass loads from the representation in @@ -1233,11 +1230,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. real :: cdrag, drag_bg_vel - logical :: new_sim, save_IC, var_force + logical :: new_sim, save_IC !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config - character(len=200) :: IC_file,filename,inputdir + character(len=200) :: IC_file, inputdir character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) @@ -1249,8 +1245,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! 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 @@ -1530,7 +1524,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, 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) + call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) else sfc_state=>sfc_state_in endif @@ -2200,7 +2194,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grouding line position is determined based on ! coupled ice-ocean dynamics. - integer :: is, iec, js, jec, i, j + integer :: is, iec, js, jec G => CS%grid US => CS%US diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index ef4ad7b6d9..778ac2ef12 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -105,8 +105,7 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) ! This subroutine sets up the grid and axis information for use by the ice shelf model. ! Local variables - integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_ct, id_ct0 - integer :: k + integer :: id_xq, id_yq, id_xh, id_yh logical :: Cartesian_grid character(len=80) :: grid_config, units_temp, set_name ! This include declares and sets the variable "version". @@ -531,7 +530,6 @@ integer function register_MOM_IS_static_field(module_name, field_name, axes, & integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) ! Local variables - character(len=240) :: mesg real :: MOM_missing_value integer :: primary_id, fms_id type(diag_ctrl), pointer :: diag_cs !< A structure that is used to regulate diagnostic output @@ -564,7 +562,7 @@ subroutine describe_option(opt_name, value, diag_CS) ! Local variables character(len=240) :: mesg - integer :: start_ind = 1, end_ind, len_ind + integer :: len_ind len_ind = len_trim(value) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 979517d227..7847da55fa 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -309,7 +309,6 @@ end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -329,13 +328,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! in a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: var_name character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics logical :: debug - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -856,7 +854,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice @@ -864,14 +861,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv + real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell vertices [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] - character(2) :: iternum - character(2) :: numproc ! for GL interpolation nsub = CS%n_sub_regularize @@ -1106,7 +1101,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - character(len=160) :: mesg ! The text of an error message real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. @@ -1133,8 +1127,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] sum_vec, sum_vec_2 - real :: tol, beta_k, area, dot_p1, resid0, cg_halo - real :: num, denom + real :: beta_k, dot_p1, resid0, cg_halo real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] @@ -1580,7 +1573,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ! o--- (3) ---o ! - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i, j, isc, iec, jsc, jec, n_flux, k, iter_count integer :: i_off, j_off integer :: iter_flag @@ -2034,7 +2027,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! computational domain -- if this function gets moves to another module, ! DO NOT TAKE THE RESTARTING BIT WITH IT integer :: i, j , isd, jsd, ied, jed - integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: isc, jsc, iec, jec integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2319,7 +2312,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground - integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt + integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2403,7 +2396,7 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_gr real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] - integer :: nsub, i, j, k, l, qx, qy, m, n + integer :: nsub, i, j, qx, qy, m, n nsub = size(Phisub,1) subarea = 1.0 / (nsub**2) @@ -2465,7 +2458,6 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(2) :: xquad real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt @@ -2589,12 +2581,11 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" ! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js, i_off, j_off real :: Visc_coef, n_g real :: ux, uy, vx, vy - real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] + real :: eps_min ! Velocity shears [T-1 ~> s-1] ! real, dimension(8,4) :: Phi - real, dimension(2) :: xquad ! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2667,7 +2658,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2741,7 +2732,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. - integer :: i, j, iters, isd, ied, jsd, jed + integer :: i, j, isd, ied, jsd, jed real :: rhoi_rhow, OD rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -2793,7 +2784,7 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4) :: xquad, yquad ! [nondim] real :: a,b,c,d ! Various lengths [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) @@ -2855,7 +2846,7 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) real, dimension(4) :: xquad, yquad ! [nondim] real :: a, d ! Interpolated grid spacings [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) @@ -2927,9 +2918,9 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! | | ! 1 - 2 - integer :: i, j, k, l, qx, qy, indx, indy + integer :: i, j, qx, qy real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx + real :: x0, y0, x, y, fracx xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) fracx = 1.0/real(nsub) @@ -3265,16 +3256,13 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + logical :: at_east_bdry, at_west_bdry real, dimension(-2:2) :: stencil real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] real :: flux_diff, phi - character (len=1) :: debug_str - - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset @@ -3435,13 +3423,12 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + logical :: at_north_bdry, at_south_bdry real, dimension(-2:2) :: stencil real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff, phi - character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7bd3b45b2a..77d1cc8a3a 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -45,7 +45,6 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P logical, intent(in), optional :: rotate_index !< If true, this is a rotation test integer, intent(in), optional :: turns !< Number of turns for rotation test - integer :: i, j character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config logical :: rotate = .false. @@ -105,7 +104,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec logical :: hmask_set - real :: len_sidestress, mask, udh + real :: len_sidestress, udh call MOM_mesg("Initialize_ice_thickness_from_file: reading thickness") @@ -196,7 +195,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos - real :: edge_pos, shelf_slope_scale, Rho_ocean + real :: edge_pos, shelf_slope_scale integer :: i, j, jsc, jec, jsd, jed, jedg, nyh, isc, iec, isd, ied integer :: j_off @@ -314,12 +313,11 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. - integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + integer :: i, j, isd, jsd, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed real :: input_thick ! The input ice shelf thickness [Z ~> m] real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) @@ -417,8 +415,7 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& character(len=200) :: ushelf_varname, vshelf_varname, & ice_visc_varname, floatfr_varname, bed_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. - integer :: i, j, isc, jsc, iec, jec - real :: len_sidestress, mask, udh + real :: len_sidestress call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") @@ -461,7 +458,6 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& filename = trim(inputdir)//trim(bed_topo_file) call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) -! isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec end subroutine initialize_ice_flow_from_file diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 9635f51262..efeb7d7f8e 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -57,12 +57,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, !! being started from a restart file. ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. - real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. - real :: flat_shelf_width ! The range over which the shelf is min_draft thick. - real :: c1 ! The maximum depths in m. character(len=40) :: mdl = "USER_initialize_shelf_mass" ! This subroutine's name. - integer :: i, j ! call MOM_error(FATAL, "USER_shelf_init.F90, USER_set_shelf_mass: " // & ! "Unmodified user routine called - you must edit the routine to use it") diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 311145bce1..310a7f9392 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -312,7 +312,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] integer :: k, nz, k_light character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. - character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + nz = GV%ke call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 498e1915ba..09814403a4 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -172,10 +172,6 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: tempH1, tempH2, tempH3, tempH4 - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: tempQ1, tempQ2, tempQ3, tempQ4 - real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: tempE1, tempE2 - real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: tempN1, tempN2 ! These arrays are a holdover from earlier code in which the arrays in G were ! macros and may have had reduced dimensions. real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: dxT, dyT, areaT @@ -527,7 +523,7 @@ subroutine set_grid_metrics_spherical(G, param_file, US) integer :: i_offset, j_offset real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) - real :: dLon,dLat,latitude,longitude,dL_di + real :: dLon, dLat, latitude, dL_di character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_spherical" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -661,7 +657,6 @@ subroutine set_grid_metrics_mercator(G, param_file, US) integer :: i, j, isd, ied, jsd, jed integer :: I_off, J_off type(GPS) :: GP - character(len=128) :: warnmesg character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" real :: PI, PI_2! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 real :: y_q, y_h, jd, x_q, x_h, id @@ -677,7 +672,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) ! Int_dj_dy at a latitude or longitude that is real :: jRef, iRef ! being set to be at grid index jRef or iRef. integer :: itt1, itt2 - logical :: debug = .FALSE., simple_area = .true. + logical, parameter :: simple_area = .true. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB ! All of the metric terms should be defined over the domain from diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 87de12a9fa..52f47f9581 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -802,7 +802,7 @@ subroutine reset_face_lengths_list(G, param_file, US) ! Local variables character(len=120), pointer, dimension(:) :: lines => NULL() character(len=120) :: line - character(len=200) :: filename, chan_file, inputdir, mesg ! Strings for file/path + character(len=200) :: filename, chan_file, inputdir ! Strings for file/path character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. real, allocatable, dimension(:,:) :: & u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees] @@ -826,7 +826,7 @@ subroutine reset_face_lengths_list(G, param_file, US) logical :: fatal_unused_lengths integer :: unused integer :: ios, iounit, isu, isv - integer :: last, num_lines, nl_read, ln, npt, u_pt, v_pt + integer :: num_lines, nl_read, ln, npt, u_pt, v_pt integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isu_por, isv_por logical :: found_u_por, found_v_por @@ -1124,7 +1124,7 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) ! list file, after removing comments. character(len=120) :: line, line_up logical :: found_u, found_v - integer :: isu, isv, icom, verbose + integer :: isu, isv, icom integer :: last num_lines = 0 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0aeba26e17..884528eae2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -151,8 +151,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !! ice shelf [ R Z ~> kg m-2 ] ! Local variables real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] - character(len=200) :: filename ! The name of an input file. - character(len=200) :: filename2 ! The name of an input files. character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config real :: H_rescale ! A rescaling factor for thicknesses from the representation in @@ -163,7 +161,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & logical :: from_Z_file, useALE logical :: new_sim - integer :: write_geom logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd logical :: verify_restart_time logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -1792,10 +1789,10 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read) !! without changing T or S. integer :: k - real :: delta_S, delta_T real :: S_top, T_top ! Reference salinity and temperature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: delta + !real :: delta_S, delta_T + !real :: delta character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's name. if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") @@ -1815,24 +1812,24 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. ! Prescribe salinity -! delta_S = S_range / ( GV%ke - 1.0 ) -! S(:,:,1) = S_top -! do k=2,GV%ke -! S(:,:,k) = S(:,:,k-1) + delta_S -! enddo + !delta_S = S_range / ( GV%ke - 1.0 ) + !S(:,:,1) = S_top + !do k=2,GV%ke + ! S(:,:,k) = S(:,:,k-1) + delta_S + !enddo do k=1,GV%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(GV%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(GV%ke)) enddo ! Prescribe temperature -! delta_T = T_range / ( GV%ke - 1.0 ) -! T(:,:,1) = T_top -! do k=2,GV%ke -! T(:,:,k) = T(:,:,k-1) + delta_T -! enddo -! delta = 1 -! T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 + !delta_T = T_range / ( GV%ke - 1.0 ) + !T(:,:,1) = T_top + !do k=2,GV%ke + ! T(:,:,k) = T(:,:,k-1) + delta_T + !enddo + !delta = 1 + !T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -2192,7 +2189,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda fields real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading oda fields - integer :: i, j, k, is, ie, js, je, nz + integer :: is, ie, js, je, nz integer :: isd, ied, jsd, jed integer, dimension(4) :: siz @@ -2392,9 +2389,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just !! and salinity in z-space; by default it is also used for ice shelf area. character(len=200) :: tfilename !< The name of an input file containing temperature in z-space. character(len=200) :: sfilename !< The name of an input file containing salinity in z-space. - character(len=200) :: shelf_file !< The name of an input file used for ice shelf area. character(len=200) :: inputdir !! The directory where NetCDF input files are. - character(len=200) :: mesg, area_varname, ice_shelf_file + character(len=200) :: mesg type(EOS_type), pointer :: eos => NULL() type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container @@ -2405,11 +2401,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, nz ! 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 :: i, j, k, ks, np, ni, nj + integer :: i, j, k, ks integer :: nkml ! The number of layers in the mixed layer. integer :: kd, inconsistent @@ -2419,20 +2414,17 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real :: PI_180 ! for conversion from degrees to radians real :: Hmix_default ! The default initial mixed layer depth [m]. real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. - real :: dilate ! A dilation factor to match topography [nondim] real :: missing_value_temp, missing_value_salt logical :: correct_thickness real :: h_tolerance ! A parameter that controls the tolerance when adjusting the ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: potemp_var, salin_var - character(len=8) :: laynum integer, parameter :: niter=10 ! number of iterations for t/s adjustment to layer density logical :: adjust_temperature = .true. ! fit t/s to target densities real, parameter :: missing_value = -1.e20 real, parameter :: temp_land_fill = 0.0, salt_land_fill = 35.0 - logical :: reentrant_x, tripolar_n,dbg - logical :: debug = .false. ! manually set this to true for verbose output + logical :: reentrant_x, tripolar_n ! data arrays real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] @@ -2470,8 +2462,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real :: tempAvg ! Spatially averaged temperatures on a layer [degC] real :: saltAvg ! Spatially averaged salinities on a layer [ppt] logical :: do_conv_adj, ignore - integer :: nPoints, ans - integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE + integer :: nPoints + integer :: id_clock_routine, id_clock_ALE id_clock_routine = cpu_clock_id('(Initialize from Z)', grain=CLOCK_ROUTINE) id_clock_ALE = cpu_clock_id('(Initialize from Z) ALE', grain=CLOCK_LOOP) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 9b6800524b..204a1e5f35 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -54,8 +54,6 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ !! This is not implemented yet. ! Local variables real :: land_fill = 0.0 - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: mesg real :: convert integer :: recnum character(len=64) :: remapScheme diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index fc76c23480..fafc7d4ca8 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -161,22 +161,14 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) type(directories) :: dirs type(grid_type), pointer :: T_grid !< global tracer grid - real, dimension(:,:), allocatable :: global2D, global2D_old - real, dimension(:), allocatable :: lon1D, lat1D, glon1D, glat1D 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 + integer :: n + integer :: isd, ied, jsd, jed integer, dimension(4) :: fld_sz character(len=32) :: assim_method - integer :: npes_pm, ens_info(6), ni, nj - character(len=128) :: mesg - character(len=32) :: fldnam + integer :: npes_pm, ens_info(6) character(len=30) :: coord_mode character(len=200) :: inputdir, basin_file - logical :: reentrant_x, reentrant_y, tripolar_N, symmetric character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file @@ -388,14 +380,8 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(ODA_CS), pointer :: CS !< ocean DA control structure 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 :: i, j, m integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg, idg_offset, jdg_offset - integer :: id - logical :: used, symmetric ! return if not time for analysis if (Time < CS%Time) return @@ -449,8 +435,8 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) logical, optional, intent(in) :: increment !< True if returning increment only type(ocean_control_struct), pointer :: Ocean_increment=>NULL() - integer :: i, j, m - logical :: used, get_inc + integer :: m + logical :: get_inc integer :: seconds_per_hour = 3600. ! return if not analysis time (retain pointers for h and tv) @@ -507,10 +493,6 @@ subroutine oda(Time, CS) type(time_type), intent(in) :: Time !< the current model time type(oda_CS), pointer :: CS !< A pointer the ocean DA control structure - integer :: i, j - integer :: m - integer :: yr, mon, day, hr, min, sec - if ( Time >= CS%Time ) then !! switch to global pelist @@ -581,7 +563,7 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid integer, intent(in) :: ens_size !< ensemble size - integer :: n,is,ie,js,je,nk + integer :: is, ie, js, je, nk nk=GV%ke is=Grid%isd;ie=Grid%ied @@ -642,8 +624,7 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) type(ODA_CS), pointer :: CS !< the data assimilation structure !! local variables - integer :: yr, mon, day, hr, min, sec - integer :: i, j, k + integer :: i, j integer :: isc, iec, jsc, jec real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_inc !< an adjustment to the temperature !! tendency [degC T-1 -> degC s-1] @@ -651,7 +632,6 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) !! tendency [g kg-1 T-1 -> g kg-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T !< The updated temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S !< The updated salinity [g kg-1] - real :: missing_value if (.not. associated(CS)) return if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 80c313e488..511bd89d7d 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -1,6 +1,6 @@ !> This module contains the routines used to apply incremental updates !! from data assimilation. -!! +! !! Applying incremental updates requires the following: !! 1. initialize_oda_incupd_fixed and initialize_oda_incupd !! 2. set_up_oda_incupd_field (tracers) and set_up_oda_incupd_vel_field (vel) @@ -137,7 +137,6 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re logical :: reset_ncount integer :: i, j, k real :: nhours_incupd, dt, dt_therm - type(vardesc) :: vd character(len=256) :: mesg character(len=64) :: remapScheme if (.not.associated(CS)) then @@ -338,7 +337,6 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) integer :: isB, ieB, jsB, jeB real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] - character(len=256) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB @@ -523,7 +521,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_oda_incupd (in). - real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 80054ffff9..bde8632170 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -705,8 +705,6 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration - real :: Lgrid, Ldeform, Lfrict - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec debugIteration = .false. @@ -1036,7 +1034,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. real :: cdrag ! The default bottom drag coefficient [nondim]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - logical :: laplacian, biharmonic, useVarMix, coldStart + logical :: laplacian, biharmonic, coldStart ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_MEKE" ! This module's name. diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 8e26014996..f7235998a6 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -291,8 +291,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] - 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] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] @@ -328,9 +326,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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_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] @@ -343,23 +338,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] - 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] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] - real :: GME_coeff_limiter ! Maximum permitted value of the GME coefficient [L2 T-1 ~> m2 s-1] - real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] - real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] - real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. - 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] @@ -392,14 +380,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] - real, dimension(SZIB_(G),SZJ_(G)) :: & - hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffu_2d ! Depth-integral of diffu [H L T-2 ~> m2 s-2] - - real, dimension(SZI_(G),SZJB_(G)) :: & - hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffv_2d ! Depth-integral of diffv [H L T-2 ~> m2 s-2] - 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 @@ -542,8 +522,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, & - !$OMP backscat_subround, GME_coeff_limiter, GME_effic_h, GME_effic_q, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & + !$OMP backscat_subround, GME_effic_h, GME_effic_q, & + !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & @@ -560,7 +540,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & !$OMP 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 dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz @@ -2553,7 +2533,7 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing - integer :: i, j, k, s, halosz + integer :: i, j, s, halosz integer :: xh, xq ! The number of valid extra halo points for h and q points. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index c426b20a6a..b152583269 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -188,9 +188,6 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G)) :: & - flux_heat_y, & - flux_prec_y real, dimension(SZI_(G),SZJ_(G)) :: & tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & @@ -654,7 +651,7 @@ subroutine sum_En(G, US, CS, En, label) character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables real :: En_sum ! The total energy in MKS units for potential output [J] - integer :: m,fr,a + integer :: a ! real :: En_sum_diff, En_sum_pdiff ! character(len=160) :: mesg ! The text of an error message ! real :: days @@ -708,7 +705,6 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, integer :: j,i,m,fr,a, is, ie, js, je real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] - real :: TKE_sum_check ! temporary for check summing real :: frac_per_sector ! fraction of energy in each wedge real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) @@ -957,7 +953,6 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) real :: I_Angle_size ! The inverse of the the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dMx, dMn real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] @@ -1174,7 +1169,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables - integer :: i, j, k, ish, ieh, jsh, jeh, m + integer :: i, j, ish, ieh, jsh, jeh, m real :: TwoPi, Angle_size real :: energized_angle ! angle through center of current wedge real :: theta ! angle at edge of wedge @@ -1191,7 +1186,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real :: slopeN,slopeW,slopeS,slopeE, bN,bW,bS,bE ! parameters defining parcel sides real :: aNE,aN,aNW,aW,aSW,aS,aSE,aE,aC ! sub-areas of advected parcel real :: a_total ! total area of advected parcel - real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel + ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x,y ! coordinates of cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx,Idy ! inverse of dx,dy at cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx,dy ! dx,dy at cell corners @@ -1468,11 +1463,11 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res real, dimension(SZIB_(G),SZJ_(G)) :: & flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. real, dimension(SZIB_(G)) :: & - cg_p, cg_m, flux1, flux2 + cg_p, flux1 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] - integer :: i, j, k, ish, ieh, jsh, jeh, a + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1548,13 +1543,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. - real, dimension(SZI_(G)) :: & - cg_p, cg_m, flux1, flux2 + real, dimension(SZI_(G)) :: cg_p, flux1 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] - character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, ish, ieh, jsh, jeh, a + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1727,7 +1720,7 @@ subroutine reflect(En, NAngle, CS, G, LB) integer :: angle_r0 ! angle-bin of reflected ray wrt equator integer :: angle_to_wall ! angle-bin relative to wall integer :: a, a0 ! loop index for angles - integer :: i, j, i_global + integer :: i, j integer :: Nangle_d2 ! Nangle / 2 integer :: isc, iec, jsc, jec ! start and end local indices on PE ! (values exclude halos) @@ -1977,7 +1970,6 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) real, parameter :: oneSixth = 1./6. real :: h_ip1, h_im1 real :: dMx, dMn - logical :: use_CW84 character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2126,7 +2118,6 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) integer, intent(in) :: jie !< End j-index for computations ! Local variables real :: curv, dh, scale - character(len=256) :: mesg ! The text of an error message integer :: i,j do j=jis,jie ; do i=iis,iie @@ -2222,10 +2213,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: var_name character(len=160) :: var_descript character(len=200) :: filename - character(len=200) :: refl_angle_file, land_mask_file + character(len=200) :: refl_angle_file character(len=200) :: refl_pref_file, refl_dbl_file, trans_file - character(len=200) :: dy_Cu_file, dx_Cv_file character(len=200) :: h2_file + !character(len=200) :: land_mask_file + !character(len=200) :: dy_Cu_file, dx_Cv_file isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index da8e936642..88e1c772a2 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -216,7 +216,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: i, j, k + integer :: i, j 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 @@ -526,7 +526,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max + integer :: i, j, k integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) @@ -876,7 +876,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max + integer :: i, j, k integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(GV)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(GV)) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7304688d32..88376e83b9 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -154,7 +154,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) real :: Khth_Loc_v(SZI_(G),SZJB_(G)) - real :: Khth_Loc(SZIB_(G),SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index f1d6e6bb57..b8a9b3134c 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -246,11 +246,9 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) real, dimension(MAX_CONSTITUENTS) :: amp_def ! Default amplitude for each tidal constituent [m] real, dimension(MAX_CONSTITUENTS) :: love_def ! Default love number for each constituent [nondim] integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. - logical :: use_const ! True if a constituent is being used. logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 logical :: use_MF, use_MM logical :: tides ! True if a tidal forcing is to be used. - logical :: FAIL_IF_MISSING = .true. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 21a22a222e..737ed8286e 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -58,7 +58,6 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: mom_comm ! list of pes for this instance of the ocean integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics - integer :: me ! my pe integer :: pe_zero ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 10b46f7e7d..ae77fa0dd6 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -434,8 +434,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers - logical :: spongeDataOngrid = .false. - integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v + integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & @@ -628,7 +627,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped - integer :: j, k, col + integer :: k, col character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return @@ -670,19 +669,11 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). ! Local variables - real, allocatable, dimension(:,:,:) :: sp_val !< Field to be used in the sponge - real, allocatable, dimension(:,:,:) :: mask_z !< Field mask for the sponge data - real, allocatable, dimension(:), target :: z_in, z_edges_in ! Heights [Z ~> m]. - real :: missing_value - integer :: j, k, col - integer :: isd,ied,jsd,jed - integer :: nPoints + integer :: isd, ied, jsd, jed integer, dimension(4) :: fld_sz integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages ! Local variables for ALE remapping - real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. - type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return ! initialize time interpolator module @@ -731,8 +722,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] - integer :: j, k, col, fld_sz(4) - character(len=256) :: mesg ! String for error messages + integer :: k, col if (.not.associated(CS)) return @@ -771,19 +761,10 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] ! Local variables - real, allocatable, dimension(:,:,:) :: u_val !< U field to be used in the sponge [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: v_val !< V field to be used in the sponge [L T-1 ~> m s-1]. - - 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 - integer :: tmp if (.not.associated(CS)) return override =.true. @@ -838,7 +819,6 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. - real :: 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_(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] @@ -852,8 +832,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) 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 + integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the ! edges in the input file [Z ~> m] diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f7378bb37b..30818a6f1f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -199,7 +199,6 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) character(len=20) :: string !< local temporary string character(len=20) :: langmuir_mixing_opt = 'NONE' !< langmuir mixing opt to be passed to CVMix, e.g., LWF16 character(len=20) :: langmuir_entrainment_opt = 'NONE' !< langmuir entrainment opt to be passed to CVMix, e.g., LWF16 - character(len=20) :: wave_method logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) !! False => compute G'(1) as in LMD94 @@ -947,7 +946,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: surfFricVel, surfBuoyFlux, Coriolis real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] - real :: rho1, rhoK, Uk, Vk, sigma, sigmaRatio + real :: Uk, Vk real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -966,11 +965,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: 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 - real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct, enhvt2 - integer :: B - real :: WST + real :: surfHuS, surfHvS, surfUs, surfVs if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") @@ -995,7 +990,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, u, v, lamult) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index aca84f59e2..b77387f521 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -174,7 +174,6 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - integer :: kOBL !< level of OBL extent real :: dh, hcorr integer :: i, k diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 11df20f5ea..73fc288731 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -321,7 +321,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, nz, nkmb, n + integer :: i, j, k, is, ie, js, je, nz, nkmb integer :: nsw ! The number of bands of penetrating shortwave radiation. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -783,8 +783,6 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! Local variables real, dimension(SZI_(G)) :: & - htot, & ! The total depth of the layers being considered for - ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the @@ -1001,7 +999,6 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! shortwave radiation, integrated over a layer ! [H R ~> kg m-2 or kg2 m-5]. real :: Idt ! 1.0/dt [T-1 ~> s-1] - real :: netHeatOut ! accumulated heat content of mass leaving ocean integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & C2, & ! Temporary variable R H-1 ~> kg m-4 or m-1]. @@ -2297,7 +2294,6 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. real :: h2_to_k1_lim, T_new, S_new, T_max, T_min, S_max, S_min - character(len=200) :: mesg integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 7aec4c0331..405251eaee 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -607,7 +607,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: chl_3d !< The chlorophyll-A concentractions of each layer [mg m-3] character(len=128) :: mesg - integer :: i, j, k, is, ie, js, je + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (.not.associated(optics)) return @@ -820,7 +820,6 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real, dimension(SZK_(GV)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD real, dimension(3) :: PE_threshold - real :: ig, E_g real :: PE_Threshold_fraction, PE, PE_Mixed, PE_Mixed_TST real :: RhoDZ_ML, H_ML, RhoDZ_ML_TST, H_ML_TST real :: Rho_ML @@ -1078,7 +1077,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t logical :: calculate_energetics logical :: calculate_buoyancy integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, n, nb + integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1558,14 +1557,13 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori ! This "include" declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. - character(len=48) :: thickness_units character(len=200) :: inputdir ! The directory where NetCDF input files character(len=240) :: chl_filename ! A file from which chl_a concentrations are to be read. character(len=128) :: chl_file ! Data containing chl_a concentrations. Used ! when var_pen_sw is defined and reading from file. 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 + 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 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8f82dce3c9..e459010481 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -578,8 +578,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. @@ -588,11 +586,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: Idt ! The inverse time step [T-1 ~> s-1] - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m - - integer :: ig, jg ! global indices for testing testing itide point source (BDM) + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1164,17 +1159,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. real :: Idt ! The inverse time step [T-1 ~> s-1] - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1643,15 +1635,12 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] temp_diag, & ! Diagnostic array of previous temperatures [degC] saln_diag ! Diagnostic array of previous salinity [ppt] real, dimension(SZI_(G),SZJ_(G)) :: & - Rcv_ml, & ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & ! These are targets so that the space can be shared with eaml & ebml. @@ -1672,9 +1661,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - real, allocatable, dimension(:,:) :: & - hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. - ! The following 3 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & eaml, & ! The equivalent of ea due to mixed layer processes [H ~> m or kg m-2]. @@ -1717,7 +1703,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree 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, m, halo + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, halo 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 @@ -2932,7 +2918,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] - integer :: num_mode logical :: use_temperature character(len=20) :: EN1, EN2, EN3 diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index eb592fb890..f55f1e27a5 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -70,7 +70,7 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real :: ustar, absf, htot real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. real :: tmp1 ! A temporary array. - integer :: i, j, k, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -159,8 +159,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. Tf, Sf, & ! New final values of the temperatures and salinities [degC] and [ppt]. dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_a, dSe_a, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_b, dSe_b, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -218,10 +216,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! accumulating the diffusivities [R Z L2 T-2 ~> J m-2]. ColHt_cor_k ! The correction to the potential energy change due to ! changes in the net column height [R Z L2 T-2 ~> J m-2]. - real :: & - b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: & - I_b1 ! The inverse of b1 [H ~> m or kg m-2]. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: Kd0 ! The value of Kddt_h that has already been applied [H ~> m or kg m-2]. real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost @@ -233,10 +228,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. - real :: dMKE_max ! The maximum amount of mean kinetic energy that could be - ! converted to turbulent kinetic energy if the velocity in - ! the layer below an interface were homogenized with all of - ! the water above the interface [R Z L2 T-2 ~> J m-2 = kg s-2]. real :: rho_here ! The in-situ density [R ~> kg m-3]. real :: PE_change ! The change in column potential energy from applying Kddt_h at the ! present interface [R L2 Z T-2 ~> J m-2]. @@ -259,9 +250,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: PE_chg_tot1D, PE_chg_tot2D, T_chg_totD real, dimension(GV%ke+1) :: dPEchg_dKd real :: PE_chg(6) - real, dimension(6) :: dT_k_itt, dS_k_itt, dT_km1_itt, dS_km1_itt - integer :: k, nz, itt, max_itt, k_cent + integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug logical :: old_PE_calc nz = GV%ke @@ -1281,11 +1271,9 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(diapyc_energy_req_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diapyc_energy_req" ! This module's name. - character(len=256) :: mesg ! Message for error messages. if (.not.associated(CS)) then ; allocate(CS) else ; return ; endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 98ab99616f..24a90cec37 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -721,7 +721,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! can improve this. real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] - logical :: FIRST_OBL ! Flag for computing "found" Mixing layer depth logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter @@ -730,7 +729,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs logical :: debug ! This is used as a hard-coded value for debugging. ! The following arrays are used only for debugging purposes. - real :: dPE_debug, mixing_debug, taux2, tauy2 + real :: dPE_debug, mixing_debug real, dimension(20) :: TKE_left_itt, PE_chg_itt, Kddt_h_itt, dPEa_dKd_itt, MKE_src_itt real, dimension(SZK_(GV)) :: mech_TKE_k, conv_PErel_k, nstar_k real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [degC] diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9884eec7a2..3fca484349 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -112,7 +112,7 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) logical :: do_i(SZI_(G)) logical :: compute_h_old, compute_T_old - integer :: i, j, k, is, ie, js, je, nz, k2, i2 + integer :: i, j, k, is, ie, js, je, nz, k2 integer :: isj, iej, num_left, nkmb, k_tgt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -388,7 +388,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_any ! True if there is more to be done on the current j-row. logical :: calc_diags ! True if diagnostic tendencies are needed. - integer :: i, j, k, is, ie, js, je, nz, i2, isj, iej + integer :: i, j, k, is, ie, js, je, nz, isj, iej is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7af12aee6f..8a0a623c1a 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -103,7 +103,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) - integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed + integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -185,7 +185,6 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) !! 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 @@ -301,12 +300,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(int_tide_input_type), pointer :: itide !< A structure containing fields related !! to the internal tide sources. ! Local variables - type(vardesc) :: vd logical :: read_tideamp ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. - character(len=20) :: tmpstr character(len=200) :: filename, tideamp_file, h2_file real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 8af8727246..f0f958d49d 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -393,7 +393,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. - logical :: do_i ! If true, work on this column. integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original ! interfaces and the interfaces with massless layers @@ -704,9 +703,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. - integer :: dt_halvings ! The number of times that the time-step is halved - ! in seeking an acceptable timestep. If none is - ! found, dt_rem*0.5^dt_halvings is used. integer :: dt_refinements ! The number of 2-fold refinements that will be used ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. @@ -1269,7 +1265,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin, Q_err_lin, TKE_src_norm + real :: K_err_lin, Q_err_lin real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 66b7a7746e..d6d2e10393 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -110,9 +110,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ real :: inv_sw_pen_scale ! The inverse of the e-folding scale [Z-1 ~> m-1]. real :: Inv_nbands ! The inverse of the number of bands of penetrating ! shortwave radiation [nondim] - logical :: call_for_surface ! if horizontal slice is the surface layer real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array for diagnosing opacity [Z-1 ~> m-1] - real :: chl(SZI_(G),SZJ_(G),SZK_(GV)) ! The concentration of chlorophyll-A [mg m-3]. real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation ! summed across all bands [Q R Z T-1 ~> W m-2]. real :: op_diag_len ! A tiny lengthscale [Z ~> m] used to remap diagnostics of opacity @@ -245,7 +243,6 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir ! radiation [Q R Z T-1 ~> W m-2]. real :: SW_nir_tot ! The sum across the near infrared bands of shortwave ! radiation [Q R Z T-1 ~> W m-2]. - type(time_type) :: day character(len=128) :: mesg integer :: i, j, k, n, is, ie, js, je, nz, nbands logical :: multiband_vis_input, multiband_nir_input, total_sw_input @@ -845,7 +842,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & logical :: SW_Remains ! If true, some column has shortwave radiation that ! was not entirely absorbed. - integer :: is, ie, nz, i, k, ks, n + integer :: is, ie, nz, i, k, n SW_Remains = .false. I_Habs = 1e3*GV%H_to_m ! optics%PenSW_absorb_Invlen @@ -962,7 +959,6 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] logical :: 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 = GV%ke diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 1f141ffd0f..90cdd9d6e6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -87,11 +87,6 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct - ! Local variables - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -163,7 +158,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) 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]. - real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. real :: wt ! The weight of the filted interfaces in setting the targets [nondim]. real :: scale ! A scaling factor [nondim]. @@ -184,7 +178,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) logical :: cols_left, ent_any, more_ent_i(SZI_(G)), ent_i(SZI_(G)) logical :: det_any, det_i(SZI_(G)) - logical :: do_j(SZJ_(G)), do_i(SZI_(G)), find_i(SZI_(G)) + logical :: do_j(SZJ_(G)), do_i(SZI_(G)) logical :: debug = .false. logical :: fatal_error character(len=256) :: mesg ! Message for error messages. @@ -717,7 +711,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. - logical :: use_temperature logical :: default_2018_answers logical :: just_read integer :: isd, ied, jsd, jed diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 0d5f1a9ca9..fd7335fd0a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -907,7 +907,6 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & hb, & ! The thickness of the bottom layer [Z ~> m]. z_from_bot ! The hieght above the bottom [Z ~> m]. - real :: Rml_base ! density of the deepest variable density layer real :: dz_int ! thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. @@ -1984,7 +1983,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: TKE_to_Kd_used ! If true, TKE_to_Kd and maxTKE need to be calculated. - integer :: i, j, is, ie, js, je + integer :: is, ie, js, je integer :: isd, ied, jsd, jed if (associated(CS)) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 93a71f6b64..761a77b399 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1925,17 +1925,16 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! to the representation in a restart file. real :: Z2_T_rescale ! A rescaling factor for vertical diffusivities and viscosities from the ! representation in a restart file to the internal representation in this run. - integer :: i, j, k, is, ie, js, je, n + integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz logical :: default_2018_answers - logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD + logical :: adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_KPP logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: use_temperature ! If true, temperature and salinity are used as state variables. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. character(len=200) :: filename, tideamp_file - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_visc" ! This module's name. diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index dee80b9e40..48e9320c8e 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -273,7 +273,6 @@ subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) !! layer density [R ~> kg m-3], for use if Iresttime_i_mean > 0. integer :: j, col - character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index be574b4356..3bc7084740 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -1026,9 +1026,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) logical :: use_Polzin, use_Simmons - character(len=160) :: mesg ! The text of an error message integer :: i, k, is, ie, nz - integer :: a, fr, m is = G%isc ; ie = G%iec ; nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d6c93a5211..3a8cb4b7ae 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1626,7 +1626,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Local variables - real :: hmix_str_dflt real :: Kv_dflt ! A default viscosity [m2 s-1]. real :: Hmix_m ! A boundary layer thickness [m]. logical :: default_2018_answers diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 2d18b7c907..604751f4ef 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -156,18 +156,8 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field - real :: PI ! 3.1415926... calculated as 4*atan(1) 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]. @@ -370,8 +360,6 @@ end subroutine DOME_tracer_surface_state subroutine DOME_tracer_end(CS) type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 013b04a5b3..d6979f6ce4 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -163,18 +163,7 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! the sponges, if they are in use. Otherwise this !! may be unassociated. - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -276,7 +265,6 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G 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 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 @@ -354,7 +342,6 @@ end subroutine ISOMIP_tracer_surface_state subroutine ISOMIP_tracer_end(CS) type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index c174fe4c39..d83dc8a6c2 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -88,7 +88,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) real, dimension(:,:,:), pointer :: tr_ptr => NULL() character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. logical :: register_CFC_cap - integer :: isd, ied, jsd, jed, nz, m + integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -193,9 +193,6 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. - ! local variables - logical :: from_file = .false. - if (.not.associated(CS)) return CS%Time => day @@ -307,7 +304,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -434,7 +431,7 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] - integer :: i, j, m, is, ie, js, je + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -577,8 +574,6 @@ end subroutine comp_CFC_schmidt subroutine CFC_cap_end(CS) type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. - ! local variables - integer :: m if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 2928a0c718..f7038b46f7 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -108,7 +108,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers [various units by element]. character(len=48) :: flux_units ! The units for tracer fluxes. logical :: register_OCMIP2_CFC - integer :: isd, ied, jsd, jed, nz, m + integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -438,7 +438,7 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in unscaled units of CFC12_flux ! CFC concentrations times meters per second [CU R Z T-1 ~> CU kg m-2 s-1] 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) + integer :: i, j, k, is, ie, js, je, nz, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -543,7 +543,7 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. real :: sc_no_term ! A term related to the Schmidt number. - integer :: i, j, m, is, ie, js, je, idim(4), jdim(4) + integer :: i, j, is, ie, js, je, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -599,7 +599,6 @@ subroutine OCMIP2_CFC_end(CS) ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. - integer :: m if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 65947fc64c..5eb286ce7d 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -109,7 +109,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? - integer :: ntau, k,i,j,axes(3) + integer :: ntau, axes(3) type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name,longname,units real, dimension(:,:,:,:), pointer :: tr_field @@ -657,7 +657,7 @@ 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, m + integer :: k, is, ie, js, je, m real, allocatable, dimension(:) :: geo_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -747,7 +747,6 @@ subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, n real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array real :: tmax0, tmin0 ! First-guest values of tmax and tmin. integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - 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 @@ -851,7 +850,6 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke) :: dzt - type(g_tracer_type), pointer :: g_tracer !Set coupler values !nnz: fake rho0 @@ -884,9 +882,6 @@ end subroutine MOM_generic_tracer_surface_state subroutine MOM_generic_flux_init(verbosity) integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - integer :: ind - character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out - real :: const_init_value character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 8efb341ec3..0faa2bbf0f 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -79,7 +79,6 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, ! local variables 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 @@ -167,7 +166,6 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer - real, dimension(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 :: tracer_int_prev !< Globally integrated tracer before LBD is applied, in mks units [conc kg] @@ -584,13 +582,14 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the velocity-point [L2 T-1 ~> m2 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 + integer :: k_bot_min !< Minimum k-index for the bottom + integer :: k_bot_max !< Maximum k-index for the bottom + integer :: k_bot_diff !< Difference between bottom left and right k-indices + !integer :: k_top_max !< Minimum k-index for the top + !integer :: k_top_min !< Maximum k-index for the top + !integer :: k_top_diff !< Difference between top left and right k-indices integer :: k_top_L, k_bot_L !< k-indices left native grid integer :: k_top_R, k_bot_R !< k-indices right native grid real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 7f1f39bbc0..f21bc9fa84 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -126,7 +126,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - character(len=256) :: mesg ! Message for error messages. character(len=80) :: string ! Temporary strings logical :: default_2018_answers logical :: boundary_extrap @@ -302,7 +301,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] - real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used [R ~> kg m-3] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer, dimension(SZI_(G), SZJ_(G)) :: k_top ! Index of the first layer within the boundary real, dimension(SZI_(G), SZJ_(G)) :: zeta_top ! Distance from the top of a layer to the intersection of the @@ -1251,7 +1249,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & logical :: searching_left_column ! True if searching for the position of a right interface in the left column logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target - logical :: search_layer logical :: fail_heff ! Fail if negative thickness are encountered. By default this ! is true, but it can take its value from hard_fail_heff. real :: dRho ! A density difference between columns [R ~> kg m-3] @@ -1446,7 +1443,7 @@ subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified - integer :: k, first_stable, prev_stable + integer :: k real :: delta_rho ! A density difference [R ~> kg m-3] do k = 1,nk @@ -1533,7 +1530,6 @@ subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 - integer :: k reached_bottom = .false. if (ki == 2) then ! At the bottom interface @@ -1596,7 +1592,6 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, & real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [ppt] real :: drho_min, drho_max ! Bounds on density differences [R ~> kg m-3] real :: ztest, zmin, zmax ! Fractional positions in the cell [nondim] - real :: dz ! Change in position in the cell [nondim] real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] integer :: iter integer :: nterm @@ -1793,7 +1788,6 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & real :: p1, p2, pmid ! Pressures [R L2 T-2 ~> Pa] real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: drds1, drds2 ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - real :: drdp1, drdp2 ! Partial derivatives of density with pressure [T2 L-2 ~> s2 m-2] ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1886,7 +1880,7 @@ function absolute_positions(n,ns,Pint,Karr,NParr) !! or other units following Pint ! Local variables - integer :: k_surface, k + integer :: k_surface do k_surface = 1, ns absolute_positions(k_surface) = absolute_position(n,ns,Pint,Karr,NParr,k_surface) @@ -1921,7 +1915,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for !! edge value calculations if continuous is false [H ~> m or kg m-2] ! Local variables - integer :: k_sublayer, klb, klt, krb, krt, k + integer :: k_sublayer, klb, klt, krb, krt real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int @@ -2112,15 +2106,11 @@ logical function ndiff_unit_tests_continuous(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 - real, dimension(nk+1) :: TiL, TiR1, TiR2, TiR4, Tio ! Test interface temperatures - real, dimension(nk) :: TL ! Test layer temperatures - real, dimension(nk+1) :: SiL ! Test interface salinities - real, dimension(nk+1) :: PiL, PiR4 ! Test interface positions - real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions - integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes - real, dimension(2*nk+1) :: hEff ! Test positions - real, dimension(2*nk+1) :: Flx ! Test flux - integer :: k + real, dimension(nk+1) :: Tio ! Test interface temperatures + real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions + integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes + real, dimension(2*nk+1) :: hEff ! Test positions + real, dimension(2*nk+1) :: Flx ! Test flux logical :: v real :: h_neglect @@ -2378,24 +2368,17 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Local variables integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: Sl, Sr ! Salinities [ppt] and temperatures [degC] real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR - real, dimension(ns-1) :: hEff, Flx + real, dimension(ns-1) :: hEff type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S - real, dimension(nk,2) :: dRdT !< Partial derivative of density with temperature at - !! cell edges [R degC-1 ~> kg m-3 degC-1] - real, dimension(nk,2) :: dRdS !< Partial derivative of density with salinity at - !! cell edges [R ppt-1 ~> kg m-3 ppt-1] logical, dimension(nk) :: stable_l, stable_r - integer :: iMethod - integer :: ns_l, ns_r integer :: k logical :: v diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index fdf199d71e..c0e10c2413 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -53,7 +53,7 @@ subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -88,7 +88,7 @@ subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -139,7 +139,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) real :: hvol ! Cell volume [H L2 ~> m3 or kg] real :: scale_factor ! A nondimensional rescaling factor between 0 and 1 [nondim] real :: max_off_cfl ! The maximum permitted fraction that can leave in a timestep [nondim] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz max_off_cfl = 0.5 @@ -227,7 +227,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) real :: abs_uh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] real :: new_uh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] real :: uh_neglect ! A negligible transport [H L2 ~> m3 or kg] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -306,7 +306,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) real :: abs_vh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] real :: new_vh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] real :: vh_neglect ! A negligible transport [H L2 ~> m3 or kg] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -380,10 +380,10 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A slice of transports [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real :: uh_neglect, uh_remain, uh_add, uh_sum, uh_col, uh_max ! Transports [H L2 ~> m3 or kg] + real :: uh_neglect, uh_remain, uh_sum, uh_col ! Transports [H L2 ~> m3 or kg] real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -475,14 +475,12 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) ! Local variables real, dimension(SZJB_(G),SZK_(GV)) :: vh2d ! A slice of transports [H L2 ~> m3 or kg] - real, dimension(SZJB_(G)) :: vh2d_sum ! Summed transports [H L2 ~> m3 or kg] real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real, dimension(SZJ_(G)) :: h2d_sum ! Summed cell volumes [H L2 ~> m3 or kg] real :: vh_neglect, vh_remain, vh_col, vh_sum ! Transports [H L2 ~> m3 or kg] real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 800523be2b..60267aa597 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -233,10 +233,9 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C integer :: niter, iter real :: Inum_iter ! The inverse of the number of iterations [nondim] character(len=256) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - logical :: z_first, x_before_y + logical :: x_before_y real :: evap_CFL_limit ! Limit on the fraction of the water that can be fluxed out of the ! top layer in a timestep [nondim] real :: minimum_forcing_depth ! The smallest depth over which fluxes can be applied [H ~> m or kg m-2] @@ -432,7 +431,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhr !< Remaining meridional mass transport [H L2 ~> m3 or kg] 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 + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iter real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] real :: prev_tot_residual, tot_residual ! The absolute value of the remaining transports [H L2 ~> m3 or kg] @@ -862,16 +861,11 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, h_new, & ! Updated thicknesses [H ~> m or kg m-2] h_vol ! Cell volumes [H L2 ~> m3 or kg] ! Work arrays for temperature and salinity - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - temp_old, temp_mean, & ! Temperatures [degC] - salt_old, salt_mean ! Salinities [ppt] - integer :: niter, iter + integer :: iter real :: dt_iter ! The timestep of each iteration [T ~> s] real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] - logical :: converged character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y @@ -1317,7 +1311,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) character(len=20) :: redistribute_method ! This include declares and sets the variable "version". # include "version_variable.h" - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1475,7 +1469,7 @@ subroutine read_all_input(CS, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer :: is, ie, js, je, isd, ied, jsd, jed, nz, t, ntime + integer :: isd, ied, jsd, jed, nz, t, ntime integer :: IsdB, IedB, JsdB, JedB nz = GV%ke ; ntime = CS%numtime diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index e8324b6043..7a2c64855f 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -38,18 +38,11 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va 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 -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters real, optional, intent(in) :: missing_val !< The missing value for the tracer real, optional, intent(in) :: land_val !< A value to use to fill in land points - ! This function initializes a tracer by reading a Z-space file, returning true if this - ! appears to have been successful, and false otherwise. -! - integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mdl = "MOM_tracer_Z_init" ! This module's name. - character(len=256) :: mesg ! Message for error messages. real, allocatable, dimension(:,:,:) :: & tr_in ! The z-space array of tracer concentrations that is read in. @@ -299,7 +292,6 @@ subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, n ! Local variables real, dimension(nk_data) :: tr_1d !< a copy of the input tracer concentrations in a column. real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. - real, dimension(nlay) :: tr_ ! A 1-d column of output tracer concentrations integer :: k_top, k_bot, k_bot_prev, kstart real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. real, dimension(nk_data) :: wt !< The fractional weight for each layer in the range between z1 and z2 @@ -398,12 +390,12 @@ 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, tr_msg, dim_msg + character(len=120) :: tr_msg, dim_msg character(:), allocatable :: edge_name character(len=256) :: dim_names(4) logical :: monotonic - integer :: ncid, status, intid, tr_id, layid, k - integer :: nz_edge, ndim, tr_dim_ids(8), sizes(4) + integer :: ncid, k + integer :: nz_edge, ndim, sizes(4) mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) @@ -599,7 +591,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] real :: max_t_adj, max_s_adj integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, kz, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 42e09b574e..f946fd46c2 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -355,8 +355,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real, dimension(SZI_(G),ntr) :: & T_tmp ! The copy of the tracer concentration at constant i,k [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: hup, hlos ! hup is the upwind volume, hlos is the ! part of that volume that might be lost ! due to advection out the other side of @@ -382,7 +380,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: mA ! Average of the reconstruction tracer edge values [conc] real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. - logical :: do_any_i logical :: usePLMslope integer :: i, j, m, n, i_up, stencil type(OBC_segment_type), pointer :: segment=>NULL() @@ -726,8 +723,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & flux_y ! The tracer flux across a boundary [H L2 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 [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: vhh(SZI_(G),SZJB_(G)) ! The meridional flux that occurs during the ! current iteration [H L2 ~> m3 or kg]. real :: hup, hlos ! hup is the upwind volume, hlos is the @@ -754,7 +749,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. - logical :: do_any_i logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil type(OBC_segment_type), pointer :: segment=>NULL() @@ -1076,8 +1070,6 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output type(tracer_advect_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 - ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_advect" ! This module's name. diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index a241776d59..4e067e6896 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -465,7 +465,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim real :: hGrounding(maxGroundings) ! The remaining fresh water flux that was not able to be ! supplied from a column that grounded out [H ~> m or kg m-2] logical :: update_h - integer :: i, j, is, ie, js, je, k, nz, n, nsw + integer :: i, j, is, ie, js, je, k, nz character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index ce747bba01..94e4b669ea 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -124,7 +124,7 @@ subroutine call_tracer_flux_init(verbosity) type(param_file_type) :: param_file ! A structure to parse for run-time parameters character(len=40) :: mdl = "call_tracer_flux_init" ! This module's name. - logical :: use_OCMIP_CFCs, use_MOM_generic_tracer, use_CFC_caps + logical :: use_OCMIP_CFCs, use_MOM_generic_tracer ! Determine which tracer routines with tracer fluxes are to be called. Note ! that not every tracer package is required to have a flux_init call. @@ -615,7 +615,7 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! real, dimension(MAX_FIELDS_) :: values type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP - integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn, n + integer :: max_ns, ns_tot, ns, index, nn, n if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & "Module must be initialized via call_tracer_register before it is used.") diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 5012cc4d66..24252dfedc 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -154,7 +154,6 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. real :: max_CFL ! The global maximum of the diffusive CFL number. logical :: use_VarMix, Resoln_scaled, do_online, use_Eady - integer :: S_idx, T_idx ! Indices for temperature and salinity if needed integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts real :: I_numitts ! The inverse of the number of iterations, num_itts. real :: scale ! The fraction of khdt_x or khdt_y that is applied in this @@ -692,7 +691,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & integer :: isd, ied, jsd, jed, IsdB, IedB, k_size integer :: kL, kR, kLa, kLb, kRa, kRb, nP, itt, ns, max_itt integer :: PEmax_kRho - integer :: isv, iev, jsv, jev ! The valid range of the indices. 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 @@ -1444,7 +1442,6 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. - character(len=256) :: mesg ! Message for error messages. if (associated(CS)) then call MOM_error(WARNING, "tracer_hor_diff_init called with associated control structure.") diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 2c77df3e74..821ac6a3cd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -367,7 +367,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) character(len=120) :: cmor_longname ! The CMOR long name of that variable. character(len=120) :: var_lname ! A temporary longname for a diagnostic. character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic - character(len=72) :: cmor_varname ! The temporary CMOR name for a diagnostic 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 diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 244eebb2bc..2921fdd124 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -172,16 +172,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! sponges, if they are in use. Otherwise this may be unassociated. real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -337,7 +328,6 @@ end subroutine RGC_tracer_column_physics subroutine RGC_tracer_end(CS) type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call to RGC_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index b37822823a..441189c0ac 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -182,23 +182,12 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB - real :: tmpx, tmpy, locx, locy + real :: locx, locy if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -360,7 +349,7 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: advection_test_stock !< the number of stocks calculated here. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, m + integer :: is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke advection_test_stock = 0 @@ -386,8 +375,6 @@ end function advection_test_stock subroutine advection_test_tracer_end(CS) type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 4f5a3ea873..a4599a891e 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -75,9 +75,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re ! Local variables character(len=40) :: mdl = "boundary_impulse_tracer" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. - character(len=3) :: name_tag ! String for creating identifying boundary_impulse character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. ! This include declares and sets the variable "version". @@ -85,7 +83,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re real, pointer :: tr_ptr(:,:,:) => NULL() real, pointer :: rem_time_ptr => NULL() logical :: register_boundary_impulse_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then @@ -169,11 +167,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, !! thermodynamic variables ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -245,10 +238,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: Isecs_per_year = 1.0 / (365.0*86400.0) - real :: year, h_total, scale, htot, Ih_limit - integer :: secs, days - integer :: i, j, k, is, ie, js, je, nz, m, k_max + integer :: i, j, k, is, ie, js, je, nz, m real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -364,8 +354,6 @@ end subroutine boundary_impulse_tracer_surface_state subroutine boundary_impulse_tracer_end(CS) type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index d7c7a7bad3..a372faa518 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -78,7 +78,6 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "regional_dyes" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. ! This include declares and sets the variable "version". @@ -200,14 +199,8 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! for the sponges, if they are in use. ! Local variables - character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - logical :: OK integer :: i, j, k, m if (.not.associated(CS)) return @@ -273,12 +266,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables 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. real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - integer :: secs, days ! Integer components of the time type. 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 @@ -402,7 +391,6 @@ end subroutine dye_tracer_surface_state subroutine regional_dyes_end(CS) type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index b6bd212a37..b82bcf7fc6 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -143,18 +143,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) !! call to dyed_obc_register_tracer. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -253,7 +242,6 @@ end subroutine dyed_obc_tracer_column_physics subroutine dyed_obc_tracer_end(CS) type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index a809e77a4c..2fdeaff02f 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -217,11 +217,6 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS ! Local variables character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - character(len=72) :: cmorname ! The CMOR name of that variable. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -387,8 +382,7 @@ function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: ideal_age_stock !< The number of stocks calculated here. ! Local variables - 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 + integer :: m ideal_age_stock = 0 if (.not.associated(CS)) return @@ -448,8 +442,6 @@ subroutine ideal_age_example_end(CS) type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index 0e66ebbcf3..2ecd2ba6e0 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -58,10 +58,8 @@ logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restar ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "nw2_tracers" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=8) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() - logical :: do_nw2 integer :: isd, ied, jsd, jed, nz, m, ig integer :: n_groups ! Number of groups of three tracers (i.e. # tracers/3) real, allocatable, dimension(:) :: timescale_in_days ! Damping timescale [days] @@ -301,8 +299,6 @@ subroutine nw2_tracers_end(CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracers. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 0c5a4e6e8d..900377fe83 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -94,7 +94,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_oil_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then @@ -220,10 +220,6 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -479,7 +475,6 @@ end subroutine oil_tracer_surface_state subroutine oil_tracer_end(CS) type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 3848b84eff..5d53c84df8 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -160,10 +160,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables real, allocatable :: temp(:,:,:) character(len=32) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() real :: PI ! 3.1415926... calculated as 4*atan(1) real :: tr_y ! Initial zonally uniform tracer concentrations. @@ -249,7 +245,8 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & endif ! All tracers but the first have 0 concentration in their inflows. As this ! is the default value, the following calls are unnecessary. - do m=2,lntr + !do m=2,lntr + do m=2,ntr call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") ! Steal from updated DOME in the fullness of time. enddo @@ -435,7 +432,6 @@ end subroutine USER_tracer_surface_state subroutine USER_tracer_example_end(CS) type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to register_USER_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 70b4bbc27d..6c64ef5596 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -110,7 +110,6 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju ! positive upward, in depth units [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz real :: x - real :: delta_h real :: min_thickness real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay character(len=40) :: verticalCoordinate @@ -233,7 +232,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, integer :: i, j, k, is, ie, js, je, nz real :: x integer :: index_bay_z - real :: delta_S, delta_T + real :: delta_S real :: S_ref, T_ref ! Reference salinity and temperature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical real :: xi0, xi1 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 248bf6c0f0..4292c6fd1b 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -100,7 +100,6 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) ! negative because it is positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. - 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 = GV%ke @@ -163,7 +162,6 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) real :: peak_damping ! The maximum sponge damping rates as the edges [days-1] real :: edge_dist ! The distance to an edge, in the same units as longitude [km] real :: sponge_width ! The width of the sponges, in the same units as longitude [km] - real :: e_dense ! The depth of the densest interfaces [Z ~> m] character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -301,7 +299,6 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! in the same units as G%geoLon [km] real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile [nondim] - character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. character(len=32) :: name ! The name of a tracer field. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm integer :: IsdB, IedB, JsdB, JedB diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index b0601e2165..a67f3b09ed 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -145,12 +145,11 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv ! usually negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - integer :: i, j, k, is, ie, js, je, nz, tmp1 - real :: x + integer :: i, j, k, is, ie, js, je, nz real :: min_thickness, s_sur, s_bot, t_sur, t_bot real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: rho_range ! The range of densities [R ~> kg m-3] - character(len=256) :: mesg ! The text of an error message + !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 = GV%ke @@ -260,17 +259,15 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt - real :: x, ds, dt real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: xi0, xi1 ! Heights in depth units [Z ~> m]. real :: S_sur, S_bot ! Salinity at the surface and bottom [ppt] real :: T_sur, T_bot ! Temperature at the bottom [degC] real :: dT_dz ! Vertical gradient of temperature [degC Z-1 ~> degC m-1]. real :: dS_dz ! Vertical gradient of salinity [ppt Z-1 ~> ppt m-1]. - real :: z ! vertical position in z space [Z ~> m] - character(len=256) :: mesg ! The text of an error message - character(len=40) :: verticalCoordinate, density_profile - real :: rho_tmp + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + !real :: rho_tmp logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. real :: T0(SZK_(GV)) ! A profile of temperatures [degC] real :: S0(SZK_(GV)) ! A profile of salinities [ppt] @@ -450,8 +447,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: min_depth, dummy1, z - real :: rho_dummy, min_thickness, rho_tmp, xi0 + real :: min_depth, dummy1 + real :: min_thickness, xi0 + !real :: rho_tmp character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index d1c89f14f3..a65dc45e73 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -127,7 +127,6 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) ! Local variables character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. real :: min_depth ! The minimum and maximum depths [Z ~> m]. - real :: PI ! 3.1415... real :: coast_offset1, coast_offset2, coast_angle, right_angle integer :: i, j diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 3077d81bb2..ab8a693ba4 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -458,7 +458,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(time_type), intent(in) :: dt !< Timestep as a time-type type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables - integer :: ii, jj, kk, b + integer :: ii, jj, b type(time_type) :: Day_Center ! Computing central time of time step @@ -1108,9 +1108,9 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: z0 ! The boundary layer depth [Z ~> m] real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] - real :: r5 ! A single expression that combines r3 and r4 [nondim] - real :: root_2kz ! The square root of twice the peak wavenumber times the - ! boundary layer depth [nondim] + ! real :: r5 ! A single expression that combines r3 and r4 [nondim] + ! real :: root_2kz ! The square root of twice the peak wavenumber times the + ! ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: PI ! 3.1415926535... diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 5d992b572f..19dc6af68a 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -41,8 +41,6 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) ! Local variables 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" @@ -167,7 +165,6 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) real, intent(in) :: x0 !< x-position of line segment end[nondim] real, intent(in) :: x1 !< x-position of line segment end[nondim] real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y @@ -263,7 +260,7 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, real :: noise ! Noise type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. - integer :: i, j, k, k1, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 7f958cfb7e..7812f66f98 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -250,7 +250,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: 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 = GV%ke diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index f2cd80d612..1ac2169a7e 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -79,7 +79,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C character(len=40) :: mdl = "RGC_initialize_sponges" ! This subroutine's name. 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 + integer :: i, j, 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 = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index c35386a2fe..53d57e99b7 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -120,9 +120,8 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & integer :: i, j, k, is, ie, js, je, nz real :: T_ref, S_ref ! Reference salinity and temerature within surface layer real :: T_range ! Range of salinities and temperatures over the vertical - real :: y, zc, zi, dTdz + real :: zc, zi, dTdz 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 = GV%ke @@ -170,7 +169,6 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just logical, intent(in) :: just_read !< If present and true, this call will only !! read parameters without setting u & v. - real :: y ! Non-dimensional coordinate across channel, 0..pi real :: T_range ! Range of salinities and temperatures over the vertical real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 degC-1 ~> m s-1 degC-1] real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] @@ -219,7 +217,7 @@ real function yPseudo( G, lat ) type(ocean_grid_type), intent(in) :: G !< Grid structure real, intent(in) :: lat !< Latitude ! Local - real :: y, PI + real :: PI PI = 4.0 * atan(1.0) yPseudo = ( ( lat - G%south_lat ) / G%len_lat ) - 0.5 ! -1/2 .. 1/.2 diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 934536d1f8..96e80f970f 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -205,12 +205,11 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, integer :: i, j, k, is, ie, js, je, nz real :: x, y, yy - integer :: index_bay_z 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 :: xi0, xi1, dSdz, delta_S, delta_S_strat + real :: dSdz, delta_S, delta_S_strat real :: adjustment_width, adjustment_deltaS real :: front_wave_amp, front_wave_length, front_wave_asym real :: eta1d(SZK_(GV)+1) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index c9cdbfa392..9a4974807f 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -218,7 +218,6 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) real, intent(in) :: x0 !< x-position of line segment end[nondim] real, intent(in) :: x1 !< x-position of line segment end[nondim] real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index d17be912ae..e042e245b7 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -238,7 +238,6 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & 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] - character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 3bfdeaa0ff..c1ea771885 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -45,7 +45,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. real :: IC_amp ! The amplitude of the initial height displacement [H ~> m or kg m-2]. - real :: diskrad, rad, xCenter, xRadius, lonC, latC, xOffset + real :: diskrad, rad, lonC, latC, xOffset ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "circle_obcs_initialization" ! This module's name. diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 2bc2533de5..7383373909 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -48,7 +48,7 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) ! Local variables integer :: i, j - real :: x, y, delta, dblen, dbfrac + real :: x, y, dblen, dbfrac logical :: dbrotate call get_param(param_file, mdl, "DUMBBELL_LEN",dblen, & @@ -217,10 +217,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file !! only read parameters without changing h. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range - real :: x, y, dblen - real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat + integer :: i, j, k, is, ie, js, je, nz + real :: S_surf, T_surf, S_range + real :: x, dblen logical :: dbrotate ! If true, rotate the domain. character(len=20) :: verticalCoordinate, density_profile @@ -293,12 +292,12 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use real :: sponge_time_scale ! The damping time scale [T ~> s] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt - real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, S ! sponge thicknesses, temp and salt + real, dimension(SZK_(GV)+1) :: eta1D ! interface positions for ALE sponge integer :: i, j, k, nz - real :: x, zi, zmid, dist, min_thickness, dblen - real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + real :: x, min_thickness, dblen + real :: S_ref, S_range logical :: dbrotate ! If true, rotate the domain. call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 54985e35fc..e97478b1a5 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -58,8 +58,6 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous !! call to dumbbell_surface_forcing_init ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -182,7 +180,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Local variables real :: S_surf ! Initial surface salinity [ppt] real :: S_range ! Range of the initial vertical distribution of salinity [ppt] - real :: x, y ! Latitude and longitude normalized by the domain size [nondim] + real :: x ! Latitude normalized by the domain size [nondim] integer :: i, j logical :: dbrotate ! If true, rotate the domain. # include "version_variable.h" diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index ff98f16529..ea7f5bc848 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -93,10 +93,8 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n - integer :: IsdB, IedB, JsdB, JedB + integer :: m, n real :: dye - type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & @@ -143,12 +141,10 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Time !< model time. ! Local variables - character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. - character(len=80) :: name real :: flow ! The OBC velocity [L T-1 ~> m s-1] real :: PI ! 3.1415926535... real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n + integer :: i, j, k, l, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 0307d93d3d..7d588b8e9c 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -39,10 +39,9 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, n, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz integer :: IsdB, IedB, JsdB, JedB real :: dye - 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 = GV%ke diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index a61d07fcc8..a3418e6482 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -34,9 +34,6 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - real :: e0(SZK_(GV)) ! The resting interface heights [Z ~> m], usually - ! negative because it is positive upward. - real :: e_pert(SZK_(GV)) ! Interface height perturbations, positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: front_displacement ! Vertical displacement acrodd front diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index a112737248..e15bcf4d4e 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -201,7 +201,7 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, param_file, ! Local variables integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range + real :: xi0, xi1, r, S_surf, T_surf, S_range, T_range real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat character(len=20) :: verticalCoordinate, density_profile diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 840f0bf3ed..3bb031bbb6 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -48,7 +48,7 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_shelfwave_OBC ! Local variables - real :: kk, ll, PI, len_lat + real :: PI, len_lat character(len=32) :: casename = "shelfwave" !< This case's name. @@ -144,8 +144,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] real :: alpha real :: x, y, jj, kk, ll - character(len=40) :: mdl = "shelfwave_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, n + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 3bafdb2d02..6422f05855 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -78,7 +78,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, # include "version_variable.h" character(len=40) :: mdl = "sloshing_initialization" !< This module's name. - integer :: i, j, k, is, ie, js, je, nx, nz + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -189,7 +189,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz - real :: delta_S, delta_T + real :: delta_T real :: S_ref, T_ref; ! Reference salinity and temerature within ! surface layer real :: S_range, T_range; ! Range of salinities and temperatures over the diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index f62aa54f88..a203fb67de 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -40,7 +40,6 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) integer :: i, j, k, is, ie, js, je, nz real :: x, y, x0, y0 real :: val1, val2, val3, val4 - character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 2438b4115a..d25ad0615c 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -70,8 +70,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: PI real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] - character(len=40) :: mdl = "tidal_bay_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 3f276a1dd0..f0ed674cf9 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -77,8 +77,6 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed - real :: kappa_fill ! diffusivity used to fill massless layers - 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 = GV%ke @@ -209,7 +207,6 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) # include "version_variable.h" character(len=40) :: mdl = "user_set_diffusivity" ! This module's name. character(len=200) :: mesg - integer :: i, j, is, ie, js, je if (associated(CS)) then call MOM_error(WARNING, "diabatic_entrain_init called with an associated "// & @@ -219,9 +216,6 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) CS%initialized = .true. - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - CS%diag => diag ! Read all relevant parameters and write them to the model log. From 861a8f14d9d70e60350ec22ec5b2f61496f5ba79 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Apr 2022 13:09:48 -0400 Subject: [PATCH 148/155] Use ODA_2018_ANSWERS to specify ODA remapping Added the new run-time parameter ODA_2018_ANSWERS to recover the answers from the previous version of the code, which did not supply properly dimensional rescaled minimum thicknesses for the remapping calls in the ODA driver. When this is set to True, all answers are bitwise identical. --- src/ocean_data_assim/MOM_oda_driver.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 867d77a495..a484fddd97 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -242,10 +242,10 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false., do_not_log=.true.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", CS%answers_2018, & + call get_param(PF, mdl, "ODA_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, & + "answers from original version of the ODA driver. Otherwise, use updated and "//& + "more robust forms of the same expressions.", default=default_2018_answers, & do_not_log=.true.) inputdir = slasher(inputdir) From e73c231fbf98360a5b912dcbd521a6761a084ecd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Apr 2022 15:39:09 -0400 Subject: [PATCH 149/155] +Set thickness_units for use by deta_dt diagnostic Added a call to set thickness_units, which are used in the units description for the diagnostic deta_dt, which was recently added by https://github.com/NOAA-GFDL/MOM6/pull/99, but with an uninitialized variable being used for the units description. This changes contents of one entry in the MOM_available_diags, which will once again reproduce across runs and compilers. All solutions are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 6482fc40fd..e78209b5ff 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1324,6 +1324,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & y_cell_method='sum', v_extensive=.true.) From 84d78a661b1d57eef7f6f98119bb055138fded6c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 21 Apr 2022 12:26:29 -0400 Subject: [PATCH 150/155] +Revised stochastics code for style compliance Revised the stochastics-related code to bring it into closer alignment with the MOM6 style guide at https://github.com/mom-ocean/MOM6/wiki/Code-style-guide, and splitting config_src/external/stochastic_physics/stochastic_physics.F90 into two files (one of which is the new file get_stochy_pattern.F90) to respect the MOM6 convention that there is only one module per file. Also renamed two stochastics-related optional arguments to ePBL_column to better reflect what they do, and corrected a number of spelling errors in comments in the files that were being modified. All answers and output are bitwise identical, but there are some minor internal interface changes. --- .../stochastic_physics/get_stochy_pattern.F90 | 22 +++++ .../stochastic_physics/stochastic_physics.F90 | 90 +++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 83 ++++++----------- .../vertical/MOM_energetic_PBL.F90 | 77 ++++++++-------- 4 files changed, 130 insertions(+), 142 deletions(-) create mode 100644 config_src/external/stochastic_physics/get_stochy_pattern.F90 diff --git a/config_src/external/stochastic_physics/get_stochy_pattern.F90 b/config_src/external/stochastic_physics/get_stochy_pattern.F90 new file mode 100644 index 0000000000..c3e23cd1a4 --- /dev/null +++ b/config_src/external/stochastic_physics/get_stochy_pattern.F90 @@ -0,0 +1,22 @@ +! The are stubs for ocean stochastic physics +! the fully functional code is available at +! http://github.com/noaa-psd/stochastic_physics +module get_stochy_pattern_mod + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public :: write_stoch_restart_ocn + +contains + +!> Write the restart file for the stochastic physics perturbations. +subroutine write_stoch_restart_ocn(sfile) + character(len=*) :: sfile !< name of restart file + + ! This stub function does not actually do anything. + return +end subroutine write_stoch_restart_ocn + +end module get_stochy_pattern_mod diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 index df62aa1591..14fa1bf289 100644 --- a/config_src/external/stochastic_physics/stochastic_physics.F90 +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -3,66 +3,56 @@ ! http://github.com/noaa-psd/stochastic_physics module stochastic_physics -implicit none +! This file is part of MOM6. See LICENSE.md for the license. -private +use MOM_error_handler, only : MOM_error, WARNING + +implicit none ; private public :: init_stochastic_physics_ocn public :: run_stochastic_physics_ocn contains -!!!!!!!!!!!!!!!!!!!! -subroutine init_stochastic_physics_ocn(delt,geoLonT,geoLatT,nx,ny,nz,pert_epbl_in,do_sppt_in, & +!> Initializes the stochastic physics perturbations. +subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_epbl_in, do_sppt_in, & mpiroot, mpicomm, iret) -implicit none -real,intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn -integer,intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid -integer,intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid -integer,intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid -real,intent(in) :: geoLonT(nx,ny) !< Longitude in degrees -real,intent(in) :: geoLatT(nx,ny) !< Latitude in degrees -logical,intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations -logical,intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations -integer,intent(in) :: mpiroot !< root processor -integer,intent(in) :: mpicomm !< mpi communicator -integer, intent(out) :: iret !< return code - -iret=0 -if (pert_epbl_in .EQV. .true. ) then - print*,'pert_epbl needs to be false if using the stub' - iret=-1 -endif -if (do_sppt_in.EQV. .true. ) then - print*,'do_sppt needs to be false if using the stub' - iret=-1 -endif -return + real, intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn [s] + integer, intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid + integer, intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid + integer, intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid + real, intent(in) :: geoLonT(nx,ny) !< Longitude in degrees + real, intent(in) :: geoLatT(nx,ny) !< Latitude in degrees + logical, intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations + logical, intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations + integer, intent(in) :: mpiroot !< root processor + integer, intent(in) :: mpicomm !< mpi communicator + integer, intent(out) :: iret !< return code + + iret=0 + if (pert_epbl_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: pert_epbl needs to be false if using the stub') + iret=-1 + endif + if (do_sppt_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_sppt needs to be false if using the stub') + iret=-1 + endif + + ! This stub function does not actually do anything. + return end subroutine init_stochastic_physics_ocn -subroutine run_stochastic_physics_ocn(sppt_wts,t_rp1,t_rp2) -implicit none -real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] -real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL - !! perturbations (KE generation) range [0,2] -real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL - !! perturbations (KE dissipation) range [0,2] -return +!> Determines the stochastic physics perturbations. +subroutine run_stochastic_physics_ocn(sppt_wts, t_rp1, t_rp2) + real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] + real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL + !! perturbations (KE generation) range [0,2] + real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL + !! perturbations (KE dissipation) range [0,2] + + ! This stub function does not actually do anything. + return end subroutine run_stochastic_physics_ocn end module stochastic_physics - -module get_stochy_pattern_mod - -private - -public :: write_stoch_restart_ocn - -contains -subroutine write_stoch_restart_ocn(sfile) - -character(len=*) :: sfile !< name of restart file -return -end subroutine write_stoch_restart_ocn - -end module get_stochy_pattern_mod diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index e459010481..1a5471c79d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -184,7 +184,7 @@ module MOM_diabatic_driver integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 - ! These are handles to diatgnostics that are only available in non-ALE layered mode. + ! These are handles to diagnostics that are only available in non-ALE layered mode. integer :: id_wd = -1 integer :: id_dudt_dia = -1, id_dvdt_dia = -1 integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 @@ -302,27 +302,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics - real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT - - if (G%ke == 1) return - - ! save copy of the date for SPPT if active - if (stoch_CS%do_sppt) then - allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) - - if (stoch_CS%id_sppt_wts > 0) then - call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) - endif - endif + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics [degC] + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics [ppt] if (GV%ke == 1) return @@ -341,7 +323,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & showCallTree = callTree_showQuery() - ! Offer diagnostics of various state varables at the start of diabatic + ! Offer diagnostics of various state variables at the start of diabatic ! these are mostly for debugging purposes. if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) @@ -353,6 +335,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call post_data(CS%id_e_predia, eta, CS%diag) endif + ! Save a copy of the initial state if stochastic perturbations are active. + if (stoch_CS%do_sppt) then + allocate(h_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; h_in(:,:,:) = h(:,:,:) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; t_in(:,:,:) = tv%T(:,:,:) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; s_in(:,:,:) = tv%S(:,:,:) + endif + if (CS%debug) then call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) @@ -455,6 +444,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! endif for frazil + if (stoch_CS%do_sppt) then + ! perturb diabatic tendencies. + ! These stochastic perturbations do not conserve heat, salt or mass. + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = max(h_in(i,j,k) + (h(i,j,k)-h_in(i,j,k)) * stoch_CS%sppt_wts(i,j), GV%Angstrom_H) + tv%T(i,j,k) = t_in(i,j,k) + (tv%T(i,j,k)-t_in(i,j,k)) * stoch_CS%sppt_wts(i,j) + tv%S(i,j,k) = max(s_in(i,j,k) + (tv%S(i,j,k)-s_in(i,j,k)) * stoch_CS%sppt_wts(i,j), 0.0) + enddo ; enddo ; enddo + deallocate(h_in, t_in, s_in) + endif ! Diagnose mixed layer depths. call enable_averages(dt, Time_end, CS%diag) @@ -476,38 +475,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn_IGW(:,:,m), CS%diag) ; enddo endif + + if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) + call disable_averaging(CS%diag) if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stoch_CS%do_sppt) then - ! perturb diabatic tendecies - do k=1,nz - do j=js,je - do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) - h_pert=h_tend+h_in(i,j,k) - t_pert=t_tend+t_in(i,j,k) - s_pert=s_tend+s_in(i,j,k) - if (h_pert > GV%Angstrom_H) then - h(i,j,k) = h_pert - else - h(i,j,k) = GV%Angstrom_H - endif - tv%T(i,j,k) = t_pert - if (s_pert > 0.0) then - tv%S(i,j,k) = s_pert - endif - enddo - enddo - enddo - deallocate(h_in) - deallocate(t_in) - deallocate(s_in) - endif - end subroutine diabatic @@ -2205,7 +2180,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif ! diagnose temperature, salinity, heat, and salt tendencies - ! Note: hold here refers to the thicknesses from before the dual-entraintment when using + ! Note: hold here refers to the thicknesses from before the dual-entrainment when using ! the bulk mixed layer scheme, so tendencies should be posted on hold. if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) @@ -2625,7 +2600,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz - logical :: do_saln_tend ! Calculate salinity-based tendency diagnosics + logical :: do_saln_tend ! Calculate salinity-based tendency diagnostics is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt @@ -3409,7 +3384,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%frazil_tendency_diag = .true. endif - ! if all is working propertly, this diagnostic should equal to hfsifrazil + ! If all is working properly, this diagnostic should equal to hfsifrazil. CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated heat tendency due to frazil formation', & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index e62db4dc36..c12921b1d9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -16,8 +16,8 @@ module MOM_energetic_PBL use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number -use MOM_stochastics, only : stochastic_CS +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_stochastics, only : stochastic_CS implicit none ; private @@ -118,7 +118,7 @@ module MOM_energetic_PBL real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 !/ mstar_scheme == 3 - real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outter-most coefficient for fit). + real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit). !! Value of 0.275 in RH18. Increasing this !! coefficient increases mechanical mixing for all values of Hf/ust, !! but is most effective at low values (weakly developed OSBLs). @@ -140,18 +140,18 @@ module MOM_energetic_PBL !/ Langmuir turbulence related parameters logical :: Use_LT = .false. !< Flag for using LT in Energy calculation integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancment + real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Ekman depth. real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with stablizing forcing. + !! the mixed layer depth over the Obukhov depth with stabilizing forcing. real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with stablizing forcing. + !! the Ekman depth over the Obukhov depth with stabilizing forcing. real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with destablizing forcing. + !! the mixed layer depth over the Obukhov depth with destabilizing forcing. real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with destablizing forcing. + !! the Ekman depth over the Obukhov depth with destabilizing forcing. real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing. !/ Others @@ -205,11 +205,11 @@ module MOM_energetic_PBL integer, parameter :: MStar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio !! of the Ekman layer depth to the Obukhov depth integer, parameter :: MStar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 -integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbolence. +integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbulence. integer, parameter :: Langmuir_rescale = 2 !< The value of LT_ENHANCE_FORM to use a multiplicative !! rescaling of mstar to account for Langmuir turbulence. integer, parameter :: Langmuir_add = 3 !< The value of LT_ENHANCE_FORM to add a contribution to - !! mstar from Langmuir turblence to other contributions. + !! mstar from Langmuir turbulence to other contributions. integer, parameter :: wT_from_cRoot_TKE = 0 !< Use a constant times the cube root of remaining TKE !! to calculate the turbulent velocity. integer, parameter :: wT_from_RH18 = 1 !< Use a scheme based on a combination of w* and v* as @@ -278,7 +278,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces !! [Z2 T-1 ~> m2 s-1]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -298,7 +298,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! mixing. ! ! The key parameters for the mixed layer are found in the control structure. -! To use the classic constant mstar mixied layers choose MSTAR_SCHEME=CONSTANT. +! To use the classic constant mstar mixed layers choose MSTAR_SCHEME=CONSTANT. ! The key parameters then include mstar, nstar, TKE_decay, and conv_decay. ! For the Oberhuber (1993) mixed layer,the values of these are: ! mstar = 1.25, nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 @@ -329,7 +329,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & Kd, & ! The diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - mixvel, & ! A turbulent mixing veloxity [Z T-1 ~> m s-1]. + mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. mixlen ! A turbulent mixing length [Z ~> m]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -427,7 +427,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) + TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & @@ -450,7 +450,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + eCD%dTKE_conv_decay ! CS%diag_TKE_unbalanced(i,j) = CS%diag_TKE_unbalanced(i,j) + eCD%dTKE_unbalanced endif - ! Write to 3-D for outputing Mixing length and velocity scale. + ! Write to 3-D for outputting Mixing length and velocity scale. if (CS%id_Mixing_Length>0) then ; do k=1,nz CS%Mixing_Length(i,j,k) = mixlen(k) enddo ; endif @@ -488,10 +488,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - if (stoch_CS%pert_epbl) then + if (stoch_CS%pert_epbl) then if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif + end subroutine energetic_PBL @@ -500,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - Waves, G, i, j, epbl1_wt, epbl2_wt) + Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -535,12 +536,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !! [Z T-1 ~> m s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation + real, optional, intent(in) :: TKE_gen_stoch !< random factor used to perturb TKE generation [nondim] + real, optional, intent(in) :: TKE_diss_stoch !< random factor used to perturb TKE dissipation [nondim] integer, intent(in) :: i !< The i-index to work on (used for Waves) integer, intent(in) :: j !< The i-index to work on (used for Waves) @@ -610,7 +611,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & MixLen_shape, & ! A nondimensional shape factor for the mixing length that - ! gives it an appropriate assymptotic value at the bottom of + ! gives it an appropriate asymptotic value at the bottom of ! the boundary layer. Kddt_h ! The diapycnal diffusivity times a timestep divided by the ! average thicknesses around a layer [H ~> m or kg m-2]. @@ -691,7 +692,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. - real :: vstar_unit_scale ! A unit converion factor for turbulent velocities [Z T-1 s m-1 ~> 1] + real :: vstar_unit_scale ! A unit conversion factor for turbulent velocities [Z T-1 s m-1 ~> 1] logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). logical :: convectively_stable ! If true the water column is convectively stable at this interface. logical :: sfc_connected ! If true the ocean is actively turbulent from the present @@ -830,8 +831,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE in the UFS - if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt + ! stochastically perturb mech_TKE in the UFS + if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -914,8 +915,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) + if (present(TKE_diss_stoch)) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * TKE_diss_stoch) else mech_TKE = mech_TKE * exp_kh endif @@ -989,7 +990,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! mixing at higher interfaces. It is an approximation to the more ! complete test dPEc_dKd_Kd0 >= 0.0, that would include the effects of ! mixing across interface K-1. The dT_to_dColHt here are effectively - ! mass-weigted estimates of dSV_dT. + ! mass-weighted estimates of dSV_dT. Convectively_stable = ( 0.0 <= & ( (dT_to_dColHt(k) + dT_to_dColHt(k-1) ) * (T0(k-1)-T0(k)) + & (dS_to_dColHt(k) + dS_to_dColHt(k-1) ) * (S0(k-1)-S0(k)) ) ) @@ -1426,7 +1427,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs end subroutine ePBL_column !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & @@ -1452,7 +1453,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! above, including implicit mixing effects with other !! yet higher layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer - !! below, including implicit mixfing effects with other + !! below, including implicit mixing effects with other !! yet lower layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other @@ -1498,7 +1499,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -1521,7 +1522,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1571,7 +1572,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & end subroutine find_PE_chg !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep +!! for several changes in an interface's diapycnal diffusivity times a timestep !! using the original form used in the first version of ePBL. subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & @@ -1635,7 +1636,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -1734,10 +1735,10 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] - real, intent(in) :: Abs_Coriolis !< abolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(out) :: Mstar !< Ouput mstar (Mixing/ustar**3) [nondim] + real, intent(out) :: Mstar !< Output mstar (Mixing/ustar**3) [nondim] real, optional, intent(in) :: Langmuir_Number !< Langmuir number [nondim] real, optional, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] real, optional, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] @@ -1902,7 +1903,7 @@ end subroutine Mstar_Langmuir !> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) - type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units @@ -1929,7 +1930,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure ! Local variables ! This include declares and sets the variable "version". @@ -2366,7 +2367,7 @@ end subroutine energetic_PBL_init !> Clean up and deallocate memory associated with the energetic_PBL module. subroutine energetic_PBL_end(CS) - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control structure character(len=256) :: mesg real :: avg_its From 1d8fb50917c8afc0284e3fd0846d8bbaef942556 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 21 Apr 2022 12:27:16 -0400 Subject: [PATCH 151/155] +Style compliance in external/drifters code Revised the external/drifters code to bring it into closer alignment with the MOM6 style guide at https://github.com/mom-ocean/MOM6/wiki/Code-style-guide. This includes using standard syntax to document variable units, the addition of 'implicit none ; private', explicit public statements, and a licensing statement to the files that were missing one, and modifications to follow the MOM6 2-point indenting convention. All answers are bitwise identical. --- .../external/drifters/MOM_particles.F90 | 48 ++++++++++--------- .../external/drifters/MOM_particles_types.F90 | 17 ++++--- 2 files changed, 35 insertions(+), 30 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index 135f5d284c..aad918e5a4 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -1,26 +1,28 @@ !> A set of dummy interfaces for compiling the MOM6 drifters code module MOM_particles_mod +! This file is part of MOM6. See LICENSE.md for the license. + use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, get_date, operator(-) use MOM_variables, only : thermo_var_ptrs +use particles_types_mod, only : particles, particles_gridded +implicit none ; private -use particles_types_mod, only: particles, particles_gridded - -public particles_run, particles_init, particles_save_restart, particles_end +public particles, particles_run, particles_init, particles_save_restart, particles_end contains !> Initializes particles container "parts" subroutine particles_init(parts, Grid, Time, dt, u, v) ! Arguments - type(particles), pointer, intent(out) :: parts !< Container for all types and memory - type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model - type(time_type), intent(in) :: Time !< Time type from parent model - real, intent(in) :: dt !< particle timestep in seconds - real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field - real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field + type(particles), pointer, intent(out) :: parts !< Container for all types and memory + type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model + type(time_type), intent(in) :: Time !< Time type from parent model + real, intent(in) :: dt !< particle timestep [s] + real, dimension(:,:,:), intent(in) :: u !< Zonal velocity field [m s-1] + real, dimension(:,:,:), intent(in) :: v !< Meridional velocity field [m s-1] end subroutine particles_init @@ -29,30 +31,30 @@ subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:),intent(in) :: uo !< Ocean zonal velocity (m/s) - real, dimension(:,:,:),intent(in) :: vo !< Ocean meridional velocity (m/s) - real, dimension(:,:,:),intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [m s-1] + real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [m s-1] + real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_save_restart(parts, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity end subroutine particles_save_restart !> Deallocate all memory and disassociated pointer -subroutine particles_end(parts,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_end(parts, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity end subroutine particles_end diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index b7bc01acb9..51e744a186 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -1,12 +1,15 @@ !> Dummy data structures and methods for drifters package module particles_types_mod +! This file is part of MOM6. See LICENSE.md for the license. + use MOM_grid, only : ocean_grid_type -use mpp_domains_mod, only: domain2D +use MOM_domains, only: domain2D +implicit none ; private !> Container for gridded fields -type :: particles_gridded +type, public :: particles_gridded type(domain2D), pointer :: domain !< MPP parallel domain integer :: halo !< Nominal halo width integer :: isc !< Start i-index of computational domain @@ -60,7 +63,7 @@ module particles_types_mod !>xyt is a data structure containing particle position and velocity fields. -type :: xyt +type, public :: xyt real :: lon !< Longitude of particle (degree N or unit of grid coordinate) real :: lat !< Latitude of particle (degree N or unit of grid coordinate) real :: day !< Day of this record (days) @@ -77,7 +80,7 @@ module particles_types_mod end type xyt !>particle types are data structures describing a tracked particle -type :: particle +type, public :: particle type(particle), pointer :: prev=>null() !< Previous link in list type(particle), pointer :: next=>null() !< Next link in list ! State variables (specific to the particles, needed for restarts) @@ -109,19 +112,19 @@ module particles_types_mod !>A buffer structure for message passing -type :: buffer +type, public :: buffer integer :: size=0 !< Size of buffer real, dimension(:,:), pointer :: data !< Buffer memory end type buffer !> A wrapper for the particle linked list (since an array of pointers is not allowed) -type :: linked_list +type, public :: linked_list type(particle), pointer :: first=>null() !< Pointer to the beginning of a linked list of parts end type linked_list !> A grand data structure for the particles in the local MOM domain -type :: particles !; private +type, public :: particles !; private type(particles_gridded) :: grd !< Container with all gridded data type(linked_list), dimension(:,:), allocatable :: list !< Linked list of particles type(xyt), pointer :: trajectories=>null() !< A linked list for detached segments of trajectories From 9b1d382ae15cc4b7fdcc91ced7bec83346217810 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 21 Apr 2022 12:27:53 -0400 Subject: [PATCH 152/155] Style compliance in external/ODA_hooks code Revised the external/ODA_hooks code to bring it into closer alignment with the MOM6 style guide at https://github.com/mom-ocean/MOM6/wiki/Code-style-guide. This includes using standard syntax to document variable units, the addition of 'implicit none ; private', and modifications to follow the MOM6 2-point indenting convention. All answers are bitwise identical. --- .../external/ODA_hooks/ocean_da_types.F90 | 158 +++++++++--------- .../external/ODA_hooks/write_ocean_obs.F90 | 12 +- 2 files changed, 82 insertions(+), 88 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index e71c76a048..a99f1ae669 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -1,90 +1,88 @@ !> Dummy aata structures and methods for ocean data assimilation. module ocean_da_types_mod - use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type - implicit none +implicit none ; private - private +!> Example type for ocean ensemble DA state +type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size !< ensemble size + real, pointer, dimension(:,:,:) :: SSH => NULL() !< sea surface height across ensembles [m] + real, pointer, dimension(:,:,:,:) :: h => NULL() !< layer thicknesses across ensembles [m or kg m-2] + real, pointer, dimension(:,:,:,:) :: T => NULL() !< layer potential temperature across ensembles [degC] + real, pointer, dimension(:,:,:,:) :: S => NULL() !< layer salinity across ensembles [ppt] + real, pointer, dimension(:,:,:,:) :: U => NULL() !< layer zonal velocity across ensembles [m s-1] + real, pointer, dimension(:,:,:,:) :: V => NULL() !< layer meridional velocity across ensembles [m s-1] +end type OCEAN_CONTROL_STRUCT - !> Example type for ocean ensemble DA state - type, public :: OCEAN_CONTROL_STRUCT - integer :: ensemble_size !< ensemble size - real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() ! Example of a profile type +type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat !< latitude [degrees_N] + real :: lon !< longitude [degrees_E] + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile + real, pointer, dimension(:) :: obs_error !< The observation error by variable [various units] + real :: loc_dist !< The impact radius of this observation [m] + type(ocean_profile_type), pointer :: next => NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev => NULL() !< previous + type(ocean_profile_type), pointer :: cnext => NULL() !< current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev => NULL() !< previous + integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile + integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile + real :: nbr_dist !< distance to nearest neighbor model gridpoint [m] + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type [various units] + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index !< model longitude indices respectively + real :: j_index !< model latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename !< a filename +end type ocean_profile_type - !> Example of a profile type - type, public :: ocean_profile_type - integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) - logical :: initialized !< a True value indicates that this profile has been allocated for use - logical :: colocated !< a True value indicated that the measurements of (num_variables) data are - !! co-located in space-time - integer :: ensemble_size !< size of the ensemble of model states used in association with this profile - integer :: num_variables !< number of measurement types associated with this profile. - integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module - integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) - !! and instrument type (XBT, CDT, etc.) - integer :: levels !< number of levels in the current profile - integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, - !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, - !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf - integer :: profile_flag !< an overall flag for the profile - real :: lat !< latitude [degrees_N] - real :: lon !< longitude [degrees_E] - logical :: accepted !< logical flag to disable a profile - type(time_type) :: time_window !< The time window associated with this profile [s] - real, pointer, dimension(:) :: obs_error !< The observation error by variable - real :: loc_dist !< The impact radius of this observation (m) - type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. - type(ocean_profile_type), pointer :: prev=>NULL() !< previous - type(ocean_profile_type), pointer :: cnext=>NULL() !< current profiles are stored as linked list. - type(ocean_profile_type), pointer :: cprev=>NULL() !< previous - integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile - integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile - real :: nbr_dist !< distance to nearest neighbor model gridpoint - logical :: compute !< profile is within current compute domain - real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] - real, dimension(:,:), pointer :: data => NULL() !< data by variable type - integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type - real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess - real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis - type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator - type(time_type) :: time !< profile time type - real :: i_index !< model longitude indices respectively - real :: j_index !< model latitude indices respectively - real, dimension(:,:), pointer :: k_index !< model depth indices - type(time_type) :: tdiff !< difference between model time and observation time - character(len=128) :: filename !< a filename - end type ocean_profile_type +!> Example forward operator type. +type, public :: forward_operator_type + integer :: num !< how many? + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef !< coefficient +end type forward_operator_type - !> Example forward operator type. - type, public :: forward_operator_type - integer :: num !< how many? - integer, dimension(2) :: state_size !< for - integer, dimension(:), pointer :: state_var_index !< for flattened data - integer, dimension(:), pointer :: i_index !< i-dimension index - integer, dimension(:), pointer :: j_index !< j-dimension index - real, dimension(:), pointer :: coef !< coefficient - end type forward_operator_type - - !> Grid type for DA - type, public :: grid_type - real, pointer, dimension(:,:) :: x=>NULL() !< x - real, pointer, dimension(:,:) :: y=>NULL() !< y - real, pointer, dimension(:,:,:) :: z=>NULL() !< z - real, pointer, dimension(:,:,:) :: h=>NULL() !< h - real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask - real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? - real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points - logical :: tripolar_N !< True for tripolar grids - integer :: ni !< ni - integer :: nj !< nj - integer :: nk !< nk - end type grid_type +!> Grid type for DA +type, public :: grid_type + real, pointer, dimension(:,:) :: x => NULL() !< x + real, pointer, dimension(:,:) :: y => NULL() !< y + real, pointer, dimension(:,:,:) :: z => NULL() !< z + real, pointer, dimension(:,:,:) :: h => NULL() !< h + real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask + real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? + real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points [m] + logical :: tripolar_N !< True for tripolar grids + integer :: ni !< ni + integer :: nj !< nj + integer :: nk !< nk +end type grid_type end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index da4a404d3d..51b5d2a1d7 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -1,16 +1,12 @@ !> Dummy interfaces for writing ODA data module write_ocean_obs_mod +use ocean_da_types_mod, only : ocean_profile_type +use MOM_time_manager, only : time_type, get_time, set_date - use ocean_da_types_mod, only : ocean_profile_type - use MOM_time_manager, only : time_type, get_time, set_date +implicit none ; private - implicit none - - private - - public :: open_profile_file, write_profile, close_profile_file, & - write_ocean_obs_init +public :: open_profile_file, write_profile, close_profile_file, write_ocean_obs_init contains From 3b05cdfdb16ed37b7c93384f010d13cbd23d6770 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 21 Apr 2022 14:36:25 -0400 Subject: [PATCH 153/155] Impose standard indentation in most driver code Corrected unbalanced indentation levels and impose MOM6-standard 2-point indentation in the config_src/driver codes, including both the FMS and mct caps and the solo_driver. The nuopc_cap is excluded from this commit because of the huge number (over 1000) of lines there that use irregular indentation. All answers are bitwise identical, and only white space changes are included. --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 2 +- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 50 +++++------ .../mct_cap/mom_surface_forcing_mct.F90 | 86 +++++++++---------- config_src/drivers/mct_cap/ocn_comp_mct.F90 | 18 ++-- .../drivers/mct_cap/ocn_cpl_indices.F90 | 10 +-- config_src/drivers/solo_driver/MOM_driver.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 4 +- 7 files changed, 85 insertions(+), 87 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 97fb869ad4..21992f5833 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1001,7 +1001,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 3bd0e1e28d..11159903ab 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -689,34 +689,34 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & OS%restart_CSp, GV=OS%GV, filename=restartname) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) - endif + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif - end if + if (BTEST(OS%Restart_control,1)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, .true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + endif end subroutine ocean_model_restart ! NAME="ocean_model_restart" @@ -1033,7 +1033,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index ebb63865b7..4adccfef65 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -289,9 +289,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) @@ -309,7 +309,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo + enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -333,7 +333,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization @@ -350,7 +350,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 - enddo; enddo + enddo ; enddo ! Salinity restoring logic if (restore_salinity) then @@ -360,7 +360,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie @@ -368,7 +368,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & @@ -391,7 +391,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & @@ -403,7 +403,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif endif @@ -417,7 +417,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo + enddo ; enddo endif ! obtain fluxes from IOB; note the staggering of indices @@ -437,26 +437,26 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) end if ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%calving)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) end if if (associated(IOB%ustar_berg)) & - fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%area_berg)) & - fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) ! GMM, cime does not not have an equivalent for heat_content_lrunoff and ! heat_content_frunoff. I am setting these to zero for now. @@ -478,7 +478,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice and snow melt heat flux [W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & @@ -522,22 +522,22 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - enddo; enddo + enddo ; enddo ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif if (associated(IOB%salt_flux)) then @@ -558,19 +558,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) - enddo; enddo + enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif @@ -680,9 +680,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) !applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -752,7 +752,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 @@ -760,7 +760,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo; enddo + enddo ; enddo ! ustar is required for the bulk mixed layer formulation. The background value ! of 0.02 Pa is a relatively small value intended to give reasonable behavior @@ -778,7 +778,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo; enddo + enddo ; enddo elseif (wind_stagger == AGRID) then call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) @@ -789,7 +789,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 @@ -797,14 +797,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo; enddo + enddo ; enddo do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - enddo; enddo + enddo ; enddo else ! C-grid wind stresses. if (G%symmetric) & @@ -827,7 +827,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) else forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif - enddo; enddo + enddo ; enddo endif ! endif for wind related fields diff --git a/config_src/drivers/mct_cap/ocn_comp_mct.F90 b/config_src/drivers/mct_cap/ocn_comp_mct.F90 index 2f7deaa716..f4b2ceed77 100644 --- a/config_src/drivers/mct_cap/ocn_comp_mct.F90 +++ b/config_src/drivers/mct_cap/ocn_comp_mct.F90 @@ -404,10 +404,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (debug .and. root_pe().eq.pe_here()) print *, "calling seq_infodata_putdata" - call seq_infodata_PutData( glb%infodata, & - ocn_nx = ni , ocn_ny = nj) - call seq_infodata_PutData( glb%infodata, & - ocn_prognostic=.true., ocnrof_prognostic=.true.) + call seq_infodata_PutData(glb%infodata, ocn_nx=ni, ocn_ny=nj) + call seq_infodata_PutData(glb%infodata, ocn_prognostic=.true., ocnrof_prognostic=.true.) if (debug .and. root_pe().eq.pe_here()) print *, "leaving ocean_init_mct" @@ -754,15 +752,15 @@ end subroutine ocn_domain_mct call seq_infodata_GetData( glb%infodata, start_type=starttype) - if ( trim(starttype) == trim(seq_infodata_start_type_start)) then - get_runtype = "initial" + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + get_runtype = "initial" else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then - get_runtype = "continue" + get_runtype = "continue" else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then - get_runtype = "branch" + get_runtype = "branch" else - write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' - call exit(0) + write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' + call exit(0) end if return diff --git a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/mct_cap/ocn_cpl_indices.F90 index a701083c0c..3f47c01903 100644 --- a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 +++ b/config_src/drivers/mct_cap/ocn_cpl_indices.F90 @@ -172,11 +172,11 @@ subroutine cpl_indices_init(ind) ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') do ncat = 1, ice_ncat - write(cncat,'(i2.2)') ncat - ncol = ncat+1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) - ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) + write(cncat,'(i2.2)') ncat + ncol = ncat+1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) + ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) enddo else mcog_ncols = 1 diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index f076b7c5a4..d6630a0f17 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -184,7 +184,7 @@ program MOM_main restart_CSp => NULL() !< A pointer to the restart control structure !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & - diag => NULL() !< A pointer to the diagnostic regulatory structure + diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7bca03ca5d..6de59684b7 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -298,7 +298,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable winds defined with no wind config") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) endif endif @@ -338,7 +338,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable buoy defined with no buoy config.") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) endif endif From 005c46066c5278028918866eee2242a7c2604f51 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 21 Apr 2022 14:48:43 -0400 Subject: [PATCH 154/155] Impose standard indentation in nuopc_cap code Corrected unbalanced indentation levels and impose MOM6-standard 2-point indentation in the config_src/driver/nuopc_cap code. There were over 1000 lines that used non-standard or unbalanced indentation, so when reviewing this commit the use of the "ignore whitespace" option might be very useful. All answers are bitwise identical, and only white space changes are included. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 1508 ++++++++--------- .../drivers/nuopc_cap/mom_cap_methods.F90 | 470 ++--- config_src/drivers/nuopc_cap/mom_cap_time.F90 | 264 +-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 64 +- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 62 +- 5 files changed, 1184 insertions(+), 1184 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 174a659f12..806aaf033e 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -214,7 +214,7 @@ subroutine SetServices(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & - specRoutine=ocean_model_finalize, rc=rc) + specRoutine=ocean_model_finalize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine SetServices @@ -286,7 +286,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) 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 + read(value,*) dbug end if write(logmsg,'(i6)') dbug call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -296,8 +296,8 @@ 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 - scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + scalar_field_name = trim(value) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 @@ -305,15 +305,15 @@ 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, *, iostat=iostat) scalar_field_count - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldCount not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + 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), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_count + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 @@ -321,15 +321,15 @@ 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, *, 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), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + 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), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_nx + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 @@ -337,15 +337,15 @@ 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, *, 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), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + 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), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_ny + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif use_coldstart = .true. @@ -367,10 +367,10 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if(use_mommesh)then geomtype = ESMF_GEOMTYPE_MESH call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif else geomtype = ESMF_GEOMTYPE_GRID endif @@ -470,17 +470,17 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif + if (localPeCount == 1) then + call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) nthrds + else + nthrds = localPeCount + endif else - nthrds = localPeCount + nthrds = localPeCount endif write(logmsg,*) nthrds call ESMF_LogWrite(trim(subname)//': nthreads = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -493,27 +493,27 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! determine the calendar if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) calendar - select case (trim(calendar)) - case ("NO_LEAP") - call set_calendar_type (NOLEAP) - case ("GREGORIAN") - call set_calendar_type (GREGORIAN) - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - end select - else - call set_calendar_type (NOLEAP) - endif + call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) calendar + select case (trim(calendar)) + case ("NO_LEAP") + call set_calendar_type (NOLEAP) + case ("GREGORIAN") + call set_calendar_type (GREGORIAN) + case default + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + end select + else + call set_calendar_type (NOLEAP) + endif else - call set_calendar_type (JULIAN) + call set_calendar_type (JULIAN) endif call diag_manager_init @@ -546,23 +546,23 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! reset shr logging to my log file if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - isPresent=isPresentLogfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + isPresent=isPresentLogfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresentDiro .and. isPresentLogfile) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + else + logunit = output_unit + endif else - logunit = output_unit + logunit = output_unit endif starttype = "" @@ -570,28 +570,28 @@ subroutine InitializeAdvertise(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(cvalue,*) starttype + read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO) endif runtype = "" if (trim(starttype) == trim('startup')) then - runtype = "initial" + runtype = "initial" else if (trim(starttype) == trim('continue') ) then - runtype = "continue" + runtype = "continue" else if (trim(starttype) == trim('branch')) then - runtype = "continue" + runtype = "continue" else if (len_trim(starttype) > 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": unknown starttype - "//trim(starttype), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = ""; restartfiles = "" @@ -606,46 +606,46 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,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 + 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 + 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 - 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, 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 + 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, 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 endif @@ -733,9 +733,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) 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") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") - end if + call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") + endif !--------- import fields ------------- @@ -917,17 +917,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif + if (localPeCount == 1) then + call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) nthrds + else + nthrds = localPeCount + endif else - nthrds = localPeCount + nthrds = localPeCount endif !$ call omp_set_num_threads(nthrds) @@ -949,7 +949,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_FAILURE call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif - ntiles=mpp_get_domain_npes(ocean_public%domain) + ntiles = mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) @@ -961,414 +961,414 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) call mpp_get_pelist(ocean_public%domain, pe) if (dbug > 1) then - do n = 1,ntiles - write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - enddo + 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) + enddo endif !--------------------------------- ! Create either a grid or a mesh !--------------------------------- - !Get the ocean grid and sizes of global and computational domains - call get_ocean_grid(ocean_state, ocean_grid) + !Get the ocean grid and sizes of global and computational domains + call get_ocean_grid(ocean_state, ocean_grid) if (geomtype == ESMF_GEOMTYPE_MESH) then - !--------------------------------- - ! Create a MOM6 mesh - !--------------------------------- - - call get_global_grid_size(ocean_grid, ni, nj) - lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) - - ! Create the global index space for the computational domain - allocate(gindex(lsize)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - jg = j + ocean_grid%jdg_offset - do i = ocean_grid%isc, ocean_grid%iec - ig = i + ocean_grid%idg_offset - k = k + 1 ! Increment position within gindex - gindex(k) = ni * (jg - 1) + ig - enddo - enddo - - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! read in the mesh - call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) - endif - - ! recreate the mesh using the above distGrid - EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - - allocate(ownedElemCoords(spatialDim*numOwnedElements)) - allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) - allocate(latMesh(numOwnedElements), lat(numOwnedElements)) - allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) - - call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - mask(n) = ocean_grid%mask2dT(ig,jg) - lon(n) = ocean_grid%geolonT(ig,jg) - lat(n) = ocean_grid%geolatT(ig,jg) - end do - end do - - eps_omesh = get_eps_omesh(ocean_state) - do n = 1,numOwnedElements - diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) - if (diff_lon > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& - "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh - call MOM_error(FATAL, err_msg) - end if - diff_lat = abs(latMesh(n) - lat(n)) - if (diff_lat > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& - "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh - call MOM_error(FATAL, err_msg) - end if - if (abs(maskMesh(n) - mask(n)) > 0) then - frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& - "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" - write(err_msg, frmt)n,maskMesh(n),mask(n) - call MOM_error(FATAL, err_msg) - end if - end do + !--------------------------------- + ! Create a MOM6 mesh + !--------------------------------- + + call get_global_grid_size(ocean_grid, ni, nj) + lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) + + ! Create the global index space for the computational domain + allocate(gindex(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex(k) = ni * (jg - 1) + ig + enddo + enddo - ! realize the import and export fields using the mesh - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! read in the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then + write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) + endif - !--------------------------------- - ! determine flux area correction factors - module variables in mom_cap_methods - !--------------------------------- - ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for - ! grids that are calculated internally + ! recreate the mesh using the above distGrid + EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Determine mesh areas for regridding - call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate (mod2med_areacor(numOwnedElements)) - allocate (med2mod_areacor(numOwnedElements)) - mod2med_areacor(:) = 1._ESMF_KIND_R8 - med2mod_areacor(:) = 1._ESMF_KIND_R8 + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) + allocate(latMesh(numOwnedElements), lat(numOwnedElements)) + allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + mask(n) = ocean_grid%mask2dT(ig,jg) + lon(n) = ocean_grid%geolonT(ig,jg) + lat(n) = ocean_grid%geolatT(ig,jg) + end do + end do + + eps_omesh = get_eps_omesh(ocean_state) + do n = 1,numOwnedElements + diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) + if (diff_lon > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& + "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh + call MOM_error(FATAL, err_msg) + end if + diff_lat = abs(latMesh(n) - lat(n)) + if (diff_lat > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& + "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh + call MOM_error(FATAL, err_msg) + end if + if (abs(maskMesh(n) - mask(n)) > 0) then + frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& + "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" + write(err_msg, frmt)n,maskMesh(n),mask(n) + call MOM_error(FATAL, err_msg) + end if + end do + + ! realize the import and export fields using the mesh + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------- + ! determine flux area correction factors - module variables in mom_cap_methods + !--------------------------------- + ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for + ! grids that are calculated internally + + ! Determine mesh areas for regridding + call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate (mod2med_areacor(numOwnedElements)) + allocate (med2mod_areacor(numOwnedElements)) + mod2med_areacor(:) = 1._ESMF_KIND_R8 + med2mod_areacor(:) = 1._ESMF_KIND_R8 #ifdef CESMCOUPLED - ! Determine model areas and flux correction factors (module variables in mom_) - call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridGetArea(lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - allocate(mesh_areas(numOwnedElements)) - allocate(model_areas(numOwnedElements)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - do i = ocean_grid%isc, ocean_grid%iec - k = k + 1 ! Increment position within gindex - if (mask(k) /= 0) then - mesh_areas(k) = dataPtr_mesh_areas(k) - model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 - mod2med_areacor(k) = model_areas(k) / mesh_areas(k) - med2mod_areacor(k) = mesh_areas(k) / model_areas(k) - end if - end do - end do - deallocate(mesh_areas) - deallocate(model_areas) - - ! Write diagnostic output for correction factors - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) - if (localPet == 0) then - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' - end if + ! Determine model areas and flux correction factors (module variables in mom_) + call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(mesh_areas(numOwnedElements)) + allocate(model_areas(numOwnedElements)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + do i = ocean_grid%isc, ocean_grid%iec + k = k + 1 ! Increment position within gindex + if (mask(k) /= 0) then + mesh_areas(k) = dataPtr_mesh_areas(k) + model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 + mod2med_areacor(k) = model_areas(k) / mesh_areas(k) + med2mod_areacor(k) = mesh_areas(k) / model_areas(k) + end if + end do + end do + deallocate(mesh_areas) + deallocate(model_areas) + + ! Write diagnostic output for correction factors + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) + call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) + call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) + call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) + if (localPet == 0) then + write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' + write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' + end if #endif - deallocate(ownedElemCoords) - deallocate(lonMesh , lon ) - deallocate(latMesh , lat ) - deallocate(maskMesh, mask) + deallocate(ownedElemCoords) + deallocate(lonMesh , lon ) + deallocate(latMesh , lat ) + deallocate(maskMesh, mask) else if (geomtype == ESMF_GEOMTYPE_GRID) then - !--------------------------------- - ! create a MOM6 grid - !--------------------------------- - - ! generate delayout and dist_grid - - allocate(deBlockList(2,2,ntiles)) - allocate(petMap(ntiles)) - allocate(deLabelList(ntiles)) - - do n = 1, ntiles - deLabelList(n) = n - deBlockList(1,1,n) = xb(n) - deBlockList(1,2,n) = xe(n) - deBlockList(2,1,n) = yb(n) - 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) - ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! 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) - !--- 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 (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 - - allocate(connectionList(2)) - - ! bipolar boundary condition at top row: nyg - call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & - orientationVector=(/-1, -2/), rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - - distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & - ! indexflag = ESMF_INDEX_DELOCAL, & - deBlockList=deBlockList, & - ! deLabelList=deLabelList, & - delayout=delayout, & - connectionList=connectionList, & - rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - deallocate(xb,xe,yb,ye,pe) - deallocate(connectionList) - deallocate(deLabelList) - deallocate(deBlockList) - deallocate(petMap) - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - 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) - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - 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) - - deallocate(IndexList) - - ! create grid - - gridIn = ESMF_GridCreate(distgrid=distgrid, & - gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & - coordSys = ESMF_COORDSYS_SPH_DEG, & - rc = rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - 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 (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 (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_xcen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_ycen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_xcor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_ycor, rc=rc) - 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 (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 (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - ! load up area, mask, center and corner values - ! area, mask, and centers should be same size in mom and esmf grid - ! corner points may not be, need to offset corner points by 1 in i and j - ! retrieve these values directly from ocean_grid, which contains halo - ! values for j=0 and wrap-around in i. on tripole seam, decomposition - ! domains are 1 larger in j; to load corner values need to loop one extra row - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - lbnd1 = lbound(dataPtr_mask,1) - ubnd1 = ubound(dataPtr_mask,1) - lbnd2 = lbound(dataPtr_mask,2) - ubnd2 = ubound(dataPtr_mask,2) - - lbnd3 = lbound(dataPtr_xcor,1) - ubnd3 = ubound(dataPtr_xcor,1) - lbnd4 = lbound(dataPtr_xcor,2) - ubnd4 = ubound(dataPtr_xcor,2) - - write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - 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, & - msg=SUBNAME//": fld and grid do not have the same size.", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) - dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) - dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) - if(grid_attach_area) then - dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) - endif - enddo - enddo - - jlast = jec - if(jec == nyg)jlast = jec+1 - - do j = jsc, jlast - j1 = j + lbnd4 - jsc - jg = j + ocean_grid%jsc - jsc - 1 - do i = isc, iec - i1 = i + lbnd3 - isc - ig = i + ocean_grid%isc - isc - 1 - dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) - dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) - enddo - enddo - - write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - 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) - endif - - write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - 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) - - write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - 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) - - gridOut = gridIn ! for now out same as in - - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------- + ! create a MOM6 grid + !--------------------------------- + + ! generate delayout and dist_grid + + allocate(deBlockList(2,2,ntiles)) + allocate(petMap(ntiles)) + allocate(deLabelList(ntiles)) + + do n = 1, ntiles + deLabelList(n) = n + deBlockList(1,1,n) = xb(n) + deBlockList(1,2,n) = xe(n) + deBlockList(2,1,n) = yb(n) + 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) + ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) + ! 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) + !--- 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 (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 + + allocate(connectionList(2)) + + ! bipolar boundary condition at top row: nyg + call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & + orientationVector=(/-1, -2/), rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + + distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & + ! indexflag = ESMF_INDEX_DELOCAL, & + deBlockList=deBlockList, & + ! deLabelList=deLabelList, & + delayout=delayout, & + connectionList=connectionList, & + rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(xb,xe,yb,ye,pe) + deallocate(connectionList) + deallocate(deLabelList) + deallocate(deBlockList) + deallocate(petMap) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) + 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) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) + 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) + + deallocate(IndexList) + + ! create grid + + gridIn = ESMF_GridCreate(distgrid=distgrid, & + gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & + coordSys = ESMF_COORDSYS_SPH_DEG, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) + 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 (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 (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_xcen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_ycen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_xcor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_ycor, rc=rc) + 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 (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 (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! load up area, mask, center and corner values + ! area, mask, and centers should be same size in mom and esmf grid + ! corner points may not be, need to offset corner points by 1 in i and j + ! retrieve these values directly from ocean_grid, which contains halo + ! values for j=0 and wrap-around in i. on tripole seam, decomposition + ! domains are 1 larger in j; to load corner values need to loop one extra row + + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + + lbnd1 = lbound(dataPtr_mask,1) + ubnd1 = ubound(dataPtr_mask,1) + lbnd2 = lbound(dataPtr_mask,2) + ubnd2 = ubound(dataPtr_mask,2) + + lbnd3 = lbound(dataPtr_xcor,1) + ubnd3 = ubound(dataPtr_xcor,1) + lbnd4 = lbound(dataPtr_xcor,2) + ubnd4 = ubound(dataPtr_xcor,2) + + write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 + 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, & + msg=SUBNAME//": fld and grid do not have the same size.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) + dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) + dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) + if(grid_attach_area) then + dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) + endif + enddo + enddo + + jlast = jec + if (jec == nyg)jlast = jec+1 + + do j = jsc, jlast + j1 = j + lbnd4 - jsc + jg = j + ocean_grid%jsc - jsc - 1 + do i = isc, iec + i1 = i + lbnd3 - isc + ig = i + ocean_grid%isc - isc - 1 + dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) + dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) + enddo + enddo + + write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) + 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) + endif + + write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) + 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) + + write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) + 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) + + gridOut = gridIn ! for now out same as in + + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1376,13 +1376,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !--------------------------------- if (len_trim(scalar_field_name) > 0) then - call State_SetScalar(real(nxg,ESMF_KIND_R8),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 (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & - scalar_field_name, scalar_field_count, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & + scalar_field_name, scalar_field_count, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1471,8 +1471,8 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - if(write_diagnostics) then - do n = 1,fldsFrOcn_num + if (write_diagnostics) then + 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 @@ -1485,7 +1485,7 @@ subroutine DataInitialize(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif end subroutine DataInitialize @@ -1589,117 +1589,117 @@ subroutine ModelAdvance(gcomp, rc) endif 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) - Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) - Time_step_coupled = 2 * esmf2fms_time(timeStep) - endif - end if + ! 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) + Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime + + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + Time_step_coupled = 2 * esmf2fms_time(timeStep) + endif + endif endif endif if (do_advance) then - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + 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 - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - !--------------- - ! Write diagnostics for import - !--------------- + !--------------- + ! Write diagnostics for import + !--------------- - if (write_diagnostics) then + if (write_diagnostics) then 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 + 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 + 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 + 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 + endif - if (dbug > 0) then - call state_diagnose(importState,subname//':IS ',rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + 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 - !--------------- + !--------------- + ! Get ocean grid + !--------------- - call get_ocean_grid(ocean_state, ocean_grid) + call get_ocean_grid(ocean_state, ocean_grid) - !--------------- - ! Import data - !--------------- + !--------------- + ! Import data + !--------------- - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------- - ! Update MOM6 - !--------------- + !--------------- + ! Update MOM6 + !--------------- - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") - call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") + if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") + call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") - !--------------- - ! Export Data - !--------------- + !--------------- + ! Export Data + !--------------- - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + 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 + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if endif !--------------- ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! If restart alarm exists and is ringing - write restart file !--------------- if (restart_mode == 'alarms') then - call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! turn off the alarm - call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! determine 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 + ! determine 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 - if (cesm_coupled) then + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) @@ -1714,36 +1714,36 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean - open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) - 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' - - 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) + 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' + + 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 ! not cesm_coupled + else ! not cesm_coupled ! write the final restart without a timestamp if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"MOM.res" - write(stoch_restartname,'(A)')"ocn_stoch.res.nc" + write(restartname,'(A)')"MOM.res" + write(stoch_restartname,'(A)')"ocn_stoch.res.nc" else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds - write(stoch_restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + write(stoch_restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) @@ -1752,20 +1752,20 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname, & stoch_restartname=stoch_restartname) - endif + endif - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - endif - end if ! restart_mode + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) + endif + endif + endif ! restart_mode !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - do n = 1,fldsFrOcn_num + 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 @@ -1778,7 +1778,7 @@ subroutine ModelAdvance(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1848,103 +1848,103 @@ subroutine ModelSetRunClock(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (first_time) then - !-------------------------------- - ! set restart alarm - !-------------------------------- + !-------------------------------- + ! set restart alarm + !-------------------------------- - ! defaults - restart_n = 0 - restart_ymd = 0 + ! defaults + restart_n = 0 + restart_ymd = 0 - if (cesm_coupled) then + if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + 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 - endif - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - 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) + ! 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 + endif + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + 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 - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + 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 - 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 (ChkErr(rc,__LINE__,u_FILE_u)) 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 (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 + ! 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO) else - ! 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) + 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 (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, 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 - endif - - if (restart_mode == 'alarms') 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) - end if + if (restart_mode == 'alarms') 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + ! 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 (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) + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) - first_time = .false. + first_time = .false. endif @@ -2002,9 +2002,9 @@ subroutine ocean_model_finalize(gcomp, rc) ! Do not write a restart unless mode is no_alarms if (restart_mode == 'no_alarms') then - write_restart = .true. + write_restart = .true. else - write_restart = .false. + write_restart = .false. end if if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & ESMF_LOGMSG_INFO) @@ -2046,9 +2046,9 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ 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) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif farrayptr(scalar_id,1) = value @@ -2085,7 +2085,7 @@ 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) + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2093,29 +2093,29 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr2d(:,:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr1d(:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0.0 endif @@ -2186,17 +2186,17 @@ subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname) ! fill in the new entry num = num + 1 if (num > fldsMax) then - call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & - msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif fldlist(num)%stdname = trim(stdname) if (present(shortname)) then - fldlist(num)%shortname = trim(shortname) + fldlist(num)%shortname = trim(shortname) else - fldlist(num)%shortname = trim(stdname) + fldlist(num)%shortname = trim(stdname) endif fldlist(num)%transferOffer = trim(transferOffer) diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index bb9743bb84..a0b6b525d4 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -37,8 +37,8 @@ module MOM_cap_methods !> Get field pointer interface State_GetFldPtr - module procedure State_GetFldPtr_1d - module procedure State_GetFldPtr_2d + module procedure State_GetFldPtr_1d + module procedure State_GetFldPtr_2d end interface integer :: import_cnt = 0!< used to skip using the import state @@ -151,14 +151,14 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! rotate taux and tauy 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%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & - - ocean_grid%sin_rot(ig,jg)*tauy(i,j) - ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & - + ocean_grid%sin_rot(ig,jg)*taux(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & + - ocean_grid%sin_rot(ig,jg)*tauy(i,j) + ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & + + ocean_grid%sin_rot(ig,jg)*taux(i,j) + enddo enddo deallocate(taux, tauy) @@ -275,11 +275,11 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! Langmuir enhancement factor !---- if ( associated(ice_ocean_boundary%lamult) ) then - ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Sw_lamult', & - isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Sw_lamult', & + isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif !---- ! Partitioned Stokes Drift Components @@ -307,24 +307,24 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! 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 + 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) @@ -374,9 +374,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Use Adcroft's rule of reciprocals; it does the right thing here. if (real(dt_int) > 0.0) then - inv_dt_int = 1.0 / real(dt_int) + inv_dt_int = 1.0 / real(dt_int) else - inv_dt_int = 0.0 + inv_dt_int = 0.0 endif !---------------- @@ -391,11 +391,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(omask(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) + enddo enddo call State_SetExport(exportState, 'ocean_mask', & @@ -431,14 +431,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(ocm_rot(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ocz(i,j) = ocean_public%u_surf(i,j) - ocm(i,j) = ocean_public%v_surf(i,j) - ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) - ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ocz(i,j) = ocean_public%u_surf(i,j) + ocm(i,j) = ocean_public%v_surf(i,j) + ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) + ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) + enddo enddo call State_SetExport(exportState, 'ocn_current_zonal', & @@ -456,9 +456,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'So_bldepth', & - isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'So_bldepth', & + isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! ------- @@ -470,14 +470,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(melt_potential(isc:iec, jsc:jec)) do j = jsc,jec - do i = isc,iec - if (ocean_public%frazil(i,j) > 0.0) then - melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int - else - melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int - if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 - endif - enddo + do i = isc,iec + if (ocean_public%frazil(i,j) > 0.0) then + melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int + else + melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int + if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 + endif + enddo enddo call State_SetExport(exportState, 'freezing_melting_potential', & @@ -491,9 +491,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'sea_level', itemFlag, rc=rc) 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'sea_level', & + isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !---------------- @@ -512,11 +512,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) do j = ocean_grid%jsc, ocean_grid%jec - jloc = j + ocean_grid%jdg_offset - do i = ocean_grid%isc,ocean_grid%iec - iloc = i + ocean_grid%idg_offset - ssh(i,j) = ocean_public%sea_lev(iloc,jloc) - enddo + jloc = j + ocean_grid%jdg_offset + do i = ocean_grid%isc,ocean_grid%iec + iloc = i + ocean_grid%idg_offset + ssh(i,j) = ocean_public%sea_lev(iloc,jloc) + enddo enddo ! Update halo of ssh so we can calculate gradients (local indexing) @@ -559,7 +559,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, do jglob = jsc, jec j = jglob + ocean_grid%jsc - jsc do iglob = isc,iec - i = iglob + ocean_grid%isc - isc + i = iglob + ocean_grid%isc - isc ! This is a PLM slope which might be less prone to the A-ocean_grid null mode slp_L = ssh(i,J) - ssh(i,J-1) * ocean_grid%mask2dCv(i,j-1) if (ocean_grid%mask2dCv(i,j-1)==0.) slp_L = 0. @@ -586,12 +586,12 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! "ocean_grid" uses has halos and uses local indexing. do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) - dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) + dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) + enddo enddo call State_SetExport(exportState, 'sea_surface_slope_zonal', & @@ -680,54 +680,54 @@ subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, a call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! determine output array and apply area correction if present - n = 0 - do j = jsc,jec - do i = isc,iec - n = n + 1 - if (present(do_sum)) then - if (present(areacor)) then - output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) - else - output(i,j) = output(i,j) + dataPtr1d(n) - end if - else - if (present(areacor)) then - output(i,j) = dataPtr1d(n) * areacor(n) - else - output(i,j) = dataPtr1d(n) - end if - endif - enddo + if (geomtype == ESMF_GEOMTYPE_MESH) then + + ! get field pointer + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! determine output array and apply area correction if present + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (present(do_sum)) then + if (present(areacor)) then + output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) + else + output(i,j) = output(i,j) + dataPtr1d(n) + end if + else + if (present(areacor)) then + output(i,j) = dataPtr1d(n) * areacor(n) + else + output(i,j) = dataPtr1d(n) + end if + endif enddo + enddo - else if (geomtype == ESMF_GEOMTYPE_GRID) then + else if (geomtype == ESMF_GEOMTYPE_GRID) then - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) - do j = jsc, jec - j1 = j + lbnd2 - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - if (present(do_sum)) then - output(i,j) = output(i,j) + dataPtr2d(i1,j1) - else - output(i,j) = dataPtr2d(i1,j1) - endif - enddo + do j = jsc, jec + j1 = j + lbnd2 - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + if (present(do_sum)) then + output(i,j) = output(i,j) + dataPtr2d(i1,j1) + else + output(i,j) = dataPtr2d(i1,j1) + endif enddo + enddo - endif + endif endif @@ -769,45 +769,45 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then + if (geomtype == ESMF_GEOMTYPE_MESH) then - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo - if (present(areacor)) then - do n = 1,(size(dataPtr1d)) - dataPtr1d(n) = dataPtr1d(n) * areacor(n) - enddo - end if - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + enddo + if (present(areacor)) then + do n = 1,(size(dataPtr1d)) + dataPtr1d(n) = dataPtr1d(n) * areacor(n) + enddo + end if + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo + enddo - endif + endif endif @@ -846,34 +846,34 @@ subroutine state_diagnose(State, string, rc) 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) + 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) @@ -901,17 +901,17 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) ! ---------------------------------------------- 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 + 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 + labort = abort endif lrank = -99 @@ -919,69 +919,69 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, 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 = ESMF_FAILURE - return - else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) - endif + lrank = 0 + if (labort) then + 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) + 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) + 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 = 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 ! 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 ", & + 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 + 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 + rank = lrank endif end subroutine field_getfldptr @@ -995,7 +995,7 @@ logical function ChkErr(rc, line, file) 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 diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 index 7f210bda71..d8ae6892a9 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_time.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90 @@ -27,32 +27,32 @@ module MOM_cap_time ! Clock and alarm options character(len=*), private, parameter :: & - optNONE = "none" , & - optNever = "never" , & - optNSteps = "nsteps" , & - optNStep = "nstep" , & - optNSeconds = "nseconds" , & - optNSecond = "nsecond" , & - optNMinutes = "nminutes" , & - optNMinute = "nminute" , & - optNHours = "nhours" , & - optNHour = "nhour" , & - optNDays = "ndays" , & - optNDay = "nday" , & - optNMonths = "nmonths" , & - optNMonth = "nmonth" , & - optNYears = "nyears" , & - optNYear = "nyear" , & - optMonthly = "monthly" , & - optYearly = "yearly" , & - optDate = "date" , & - optIfdays0 = "ifdays0" , & - optGLCCouplingPeriod = "glc_coupling_period" + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optIfdays0 = "ifdays0" , & + optGLCCouplingPeriod = "glc_coupling_period" ! Module data integer, parameter :: SecPerDay = 86400 ! Seconds per day character(len=*), parameter :: u_FILE_u = & - __FILE__ + __FILE__ contains @@ -66,7 +66,7 @@ module MOM_cap_time !! In the logic below we set an appropriate "NextAlarm" and then !! we make sure to advance it properly based on the ring interval. subroutine AlarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) type(ESMF_Clock) , intent(inout) :: clock !< ESMF clock type(ESMF_Alarm) , intent(inout) :: alarm !< ESMF alarm character(len=*) , intent(in) :: option !< alarm option @@ -109,20 +109,20 @@ subroutine AlarmInit( clock, alarm, option, & trim(option) == optNMonths .or. trim(option) == optNMonth .or. & trim(option) == optNYears .or. trim(option) == optNYear .or. & trim(option) == optIfdays0) then - if (.not. present(opt_n)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (opt_n <= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' invalid opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif + if (.not. present(opt_n)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (opt_n <= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' invalid opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif endif call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) @@ -136,9 +136,9 @@ subroutine AlarmInit( clock, alarm, option, & ! initial guess of next alarm, this will be updated below if (present(RefTime)) then - NextAlarm = RefTime + NextAlarm = RefTime else - NextAlarm = CurrTime + NextAlarm = CurrTime endif ! Determine calendar @@ -149,109 +149,109 @@ subroutine AlarmInit( clock, alarm, option, & selectcase (trim(option)) case (optNONE, optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optDate) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (lymd < 0 .or. ltod < 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optIfdays0) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNSteps, optNStep) - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNYears, optNYear) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + 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 (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' unknown option: '//trim(option), & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' unknown option: '//trim(option), & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return end select @@ -263,10 +263,10 @@ subroutine AlarmInit( clock, alarm, option, & ! --- most options above. go back one alarminterval just to be careful if (update_nextalarm) then - NextAlarm = NextAlarm - AlarmInterval - do while (NextAlarm <= CurrTime) - NextAlarm = NextAlarm + AlarmInterval - enddo + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo endif alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) @@ -299,15 +299,15 @@ subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) if (present(desc)) ldesc = desc if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then - if (present(logunit)) then - write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & - 'time-of-day out of bounds', ymd, ltod - endif - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' yymmdd is negative or time-of-day out of bounds ', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + if (present(logunit)) then + write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & + 'time-of-day out of bounds', ymd, ltod + endif + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' yymmdd is negative or time-of-day out of bounds ', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return endif call date2ymd (ymd,yr,mon,day) @@ -330,7 +330,7 @@ subroutine date2ymd (date, year, month, day) tdate = abs(date) year = int(tdate/10000) if (date < 0) then - year = -year + year = -year endif month = int( mod(tdate,10000)/ 100) day = mod(tdate, 100) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 448f23140e..a44e126461 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -724,38 +724,38 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & - OS%dirs%restart_output_dir) - endif + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) ! Is this needed? + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + OS%dirs%restart_output_dir) + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif + if (BTEST(OS%Restart_control,1)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, .true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif endif if (present(stoch_restartname)) then - if (OS%do_sppt .OR. OS%pert_epbl) then - call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) - endif + if (OS%do_sppt .OR. OS%pert_epbl) then + call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) + endif endif end subroutine ocean_model_restart @@ -839,9 +839,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) @@ -1099,7 +1099,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 3c03009d43..da4c15e528 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -315,9 +315,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) @@ -453,7 +453,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, return endif if (associated(IOB%lrunoff)) then - if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) + if (CS%liquid_runoff_from_data) call data_override('OCN', 'runoff', IOB%lrunoff, Time) endif ! obtain fluxes from IOB; note the staggering of indices @@ -503,30 +503,30 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice and snow melt heat flux [Q R Z T-1 ~> W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) fluxes%latent(i,j) = 0.0 ! notice minus sign since fprec is positive into the ocean if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! notice minus sign since frunoff is positive into the ocean if (associated(IOB%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & - IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) @@ -547,10 +547,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice fraction [nondim] if (associated(IOB%ice_fraction) .and. associated(fluxes%ice_fraction)) & - fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) + fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) ! 10-m wind speed squared [m2/s2] if (associated(IOB%u10_sqr) .and. associated(fluxes%u10_sqr)) & - fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) + fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) enddo ; enddo @@ -568,18 +568,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif ! CFCs @@ -733,9 +733,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then From 0e8acd90b46656ccb7fbc73bc5911ef2733a345c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 May 2022 13:22:12 -0400 Subject: [PATCH 155/155] +(*)Fix a scaling bug in MOM_horizontal_regridding Avoids using hard-coded dimensional tolerances in horizontal_regridding and improves the documentation of the variables and their units in this file. Without this change, calls to horiz_interp_and_extrap_tracer with a non-unity conversion factor will exhibit unexpected changes in answers, and may have wildly inappropriate amounts of smoothing of the interpolated values in arrays that are initialized from z-space file. However, the defaults are carefully chosen to avoid changing answers in any cases that do not use rescaling of tracer concentrations. The specific changes include: - Add a new optional argument tr_iter_tol to the horiz_interp_and_extrap_tracer routines to set an appropriate dimensional threshold for when the post-fill smoothing of tracers should be considered to be adequate. - Make the dimensional crit argument to fill_miss_2d non-optional, and fill it with appropriate values in calls from the horiz_interp_and_extrap_tracer routines when tr_iter_tol is not present. There should never be a hard-coded non-zero default for a dimensional variable! - Add a new optional scale argument to myStats - Eliminate the unused and unnecessary smooth logical argument to fill_miss_2d; the same functionality is obtained by setting the num_pass argument to 0. - Added to comments to document the units or unitlessness of the real variables in MOM_horizontal_regridding.F90. - Made minor changes to make the duplicated portions of the two horiz_interp_and_extrap_tracer similar. By default, all answers are bitwise identical, but this corrects a subtle bug with the use of the conversion factor argument in horiz_interp_and_extrap_tracer calls. There are new optional arguments to publicly visible routines. --- src/framework/MOM_horizontal_regridding.F90 | 479 +++++++++++--------- 1 file changed, 259 insertions(+), 220 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 5c8035e9b2..ebc59cd288 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -35,21 +35,25 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, is, ie, js, je, k, mesg) - real, dimension(:,:), intent(in) :: array !< input array (ND) - real, intent(in) :: missing !< missing value (ND) - integer :: is !< Start index in i - integer :: ie !< End index in i - integer :: js !< Start index in j - integer :: je !< End index in j - integer :: k !< Level to calculate statistics for - character(len=*) :: mesg !< Label to use in message +subroutine myStats(array, missing, is, ie, js, je, k, mesg, scale) + real, dimension(:,:), intent(in) :: array !< input array [A] + real, intent(in) :: missing !< missing value [A] + integer, intent(in) :: is !< Start index in i + integer, intent(in) :: ie !< End index in i + integer, intent(in) :: js !< Start index in j + integer, intent(in) :: je !< End index in j + integer, intent(in) :: k !< Level to calculate statistics for + character(len=*), intent(in) :: mesg !< Label to use in message + real, optional, intent(in) :: scale !< A scaling factor for output. ! Local variables - real :: minA, maxA + real :: minA, maxA ! Minimum and maximum vvalues in the array [A] + real :: scl ! A factor for undoing any scaling of the array statistics for output. integer :: i,j logical :: found character(len=120) :: lMesg - minA = 9.E24 ; maxA = -9.E24 ; found = .false. + + scl = 1.0 ; if (present(scale)) scl = scale + minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. do j=js,je ; do i=is,ie if (array(i,j) /= array(i,j)) stop 'Nan!' @@ -68,7 +72,7 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) call max_across_PEs(maxA) if (is_root_pe()) then write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') & - 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) + 'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif @@ -77,50 +81,47 @@ end subroutine myStats !> 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 - +subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, answers_2018) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: aout !< The array with missing values to fill + intent(inout) :: aout !< The array with missing values to fill [A] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). + !! (1==good data; 0==missing data) [nondim]. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: fill !< Same shape array of points which need - !! filling (1==fill;0==dont fill) + !! filling (1==fill;0==dont fill) [nondim] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: prev !< First guess where isolated holes exist. - logical, optional, intent(in) :: smooth !< If present and true, apply a number of - !! Laplacian iterations to the interpolated data + intent(in) :: prev !< First guess where isolated holes exist [A] + real, intent(in) :: acrit !< A minimal value for deltas between iterations that + !! determines when the smoothing has converged [A]. integer, optional, intent(in) :: num_pass !< The maximum number of iterations - real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) - real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian [nondim] logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. - 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 + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [A] + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [A] + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] + + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [A] + real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values [nondim] + real :: ngood ! The number of valid values in neighboring points [nondim] + real :: nfill ! The remaining number of points to fill [nondim] + real :: nfill_prev ! The previous value of nfill [nondim] character(len=256) :: mesg ! The text of an error message integer :: i, j, k integer, parameter :: num_pass_default = 10000 - real, parameter :: relc_default = 0.25, crit_default = 1.e-3 + real, parameter :: relc_default = 0.25 ! The default relaxation coefficient [nondim] - integer :: npass + integer :: npass ! The maximum number of passes of the Laplacian smoother integer :: is, ie, js, je - real :: relax_coeff, acrit, ares + real :: relax_coeff ! The grid-scale Laplacian relaxation coefficient per timestep [nondim] + real :: ares ! The maximum magnitude change in aout [A] logical :: debug_it, ans_2018 debug_it=.false. @@ -134,12 +135,6 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, relax_coeff = relc_default if (PRESENT(relc)) relax_coeff = relc - acrit = crit_default - if (PRESENT(crit)) acrit = crit - - do_smooth=.false. - if (PRESENT(smooth)) do_smooth=smooth - ans_2018 = .true. ; if (PRESENT(answers_2018)) ans_2018 = answers_2018 fill_pts(:,:) = fill(:,:) @@ -193,7 +188,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - if (nfill == nfill_prev .and. PRESENT(prev)) then + if (nfill == nfill_prev) then do j=js,je ; do i=is,ie ; if (fill_pts(i,j) == 1.0) then aout(i,j) = prev(i,j) fill_pts(i,j) = 0.0 @@ -214,7 +209,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, 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 + do k=1,npass call pass_var(aout,G%Domain) do j=js,je ; do i=is,ie if (fill(i,j) == 1) then @@ -240,7 +235,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, enddo ; enddo call max_across_PEs(ares) if (ares <= acrit) exit - enddo ; endif + enddo do j=js,je ; do i=is,ie if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then @@ -254,56 +249,70 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record -subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & - mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z, answers_2018, ongrid) +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & + homogenize, m_to_Z, answers_2018, ongrid, tr_iter_tol) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. character(len=*), intent(in) :: varnam !< Name of tracer in file. - real, intent(in) :: conversion !< Conversion factor for tracer. + real, intent(in) :: conversion !< Conversion factor for tracer [CU conc-1 ~> 1] integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and input-file vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels. [CU ~> conc] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and input-file vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! with conversion to avoid accidentally having valid + !! values match missing values [CU ~> conc] logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated !! to the model horizontal grid. In this case, only !! extrapolation is performed by this routine + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating [CU ~> conc] ! Local variables 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 - integer :: id, jd, kd, jdp + !! native horizontal grid, with units that change + !! as the input data is interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes integer :: i, j, k integer, dimension(4) :: start, count - real, dimension(:,:), allocatable :: x_in, y_in - 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, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. - real :: add_offset, scale_factor + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: pole ! The sum of tracer values at the pole [conc] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [conc] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] + real :: add_offset, scale_factor ! File-specific conversion factors. logical :: found_attr logical :: add_np logical :: is_ongrid @@ -315,15 +324,21 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read logical :: debug=.false. - real :: 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 + real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [CU ~> conc] + real :: npoints ! The number of points in an average [nondim] + real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -334,8 +349,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, is_ongrid = .false. if (present(ongrid)) is_ongrid = ongrid - if (allocated(tr_z)) deallocate(tr_z) - if (allocated(mask_z)) deallocate(mask_z) + dtr_iter_stop = 1.0e-3*conversion + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / conversion PI_180 = atan(1.0)/45. @@ -356,7 +373,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call get_axis_info(axes_info(3),ax_size=kd) 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)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) call get_axis_info(axes_info(1),ax_data=lon_in) call get_axis_info(axes_info(2),ax_data=lat_in) @@ -366,12 +384,12 @@ 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 northern-most latitude add_np = .false. jdp = jd if (.not. is_ongrid) then max_lat = maxval(lat_in) if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -385,11 +403,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! construct level cell boundaries as the mid-point between adjacent centers ! Set the I/O attributes - call read_attribute(trim(filename), "_FillValue", missing_value, & + call read_attribute(trim(filename), "_FillValue", missing_val_in, & varname=trim(varnam), found=found_attr) if (.not. found_attr) call MOM_error(FATAL, & "error finding missing value for " // trim(varnam) // & " in file " // trim(filename) // " in hinterp_extrap") + missing_value = conversion * missing_val_in call read_attribute(trim(filename), "scale_factor", scale_factor, & varname=trim(varnam), found=found_attr) @@ -425,21 +444,22 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call max_across_PEs(max_depth) if (z_edges_in(kd+1) < max_depth) z_edges_in(kd+1) = max_depth - roundoff = 3.0*EPSILON(missing_value) + roundoff = 3.0*EPSILON(missing_val_in) - ! 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) - mask_in = 0.0 + mask_in(:,:) = 0.0 + tr_out(:,:) = 0.0 + if (is_ongrid) then start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1; start(4) = 1; count(4) = 1 call MOM_read_data(trim(filename), trim(varnam), tr_in, G%Domain, timelevel=1) do j=js,je do i=is,ie - if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion else @@ -447,7 +467,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, endif enddo enddo - else + + tr_out(is:ie,js:je) = tr_in(is:ie,js:je) + + else ! .not.is_ongrid + start(:) = 1 ; start(3) = k count(:) = 1 ; count(1) = id ; count(2) = jd call read_variable(trim(filename), trim(varnam), tr_in, start=start, nread=count) @@ -455,15 +479,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) npole = npole + 1.0 endif enddo if (npole > 0) then - pole=pole/npole + pole = pole / npole else - pole=missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -474,80 +498,65 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call broadcast(tr_inp, id*jdp, blocking=.true.) - 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 + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo -! call fms routine horiz_interp to interpolate input level data to model horizontal grid - if (.not. is_ongrid) then + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then 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 - call myStats(tr_inp,missing_value, is, ie, js, je, k,'Tracer from file') + call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) endif - endif - tr_out(:,:) = 0.0 - 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) - endif + endif ! End of .not.is_ongrid - mask_out=1.0 - do j=js,je - do i=is,ie - if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. - enddo - enddo + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo - fill = 0.0; good = 0.0 + fill(:,:) = 0.0 ; good(:,:) = 0.0 nPoints = 0 ; varAvg = 0. - do j=js,je - do i=is,ie - if (mask_out(i,j) < 1.0) then - tr_out(i,j)=missing_value - else - good(i,j)=1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) - endif - if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & - (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 - enddo - enddo - call pass_var(fill,G%Domain) - call pass_var(good,G%Domain) + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + nPoints = nPoints + 1 + varAvg = varAvg + tr_out(i,j) + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j) = 1.0 + enddo ; enddo + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out,missing_value, is,ie,js,je,k,'variable from horiz_interp()') + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) endif ! 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 + if (PRESENT(homogenize)) then ; if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. + call sum_across_PEs(nPoints) + call sum_across_PEs(varAvg) + if (nPoints>0) then + varAvg = varAvg / real(nPoints) endif - endif + tr_out(:,:) = varAvg + endif ; endif ! tr_out contains input z-space data on the model grid with missing values ! now fill in missing values using "ICE-nine" algorithm. @@ -556,9 +565,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, & + answers_2018=answers_2018) if (debug) then - call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') + call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -567,7 +577,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) endif enddo ! kd @@ -578,51 +588,65 @@ end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & - z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, spongeOngrid, m_to_Z, answers_2018) + z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & + homogenize, spongeOngrid, m_to_Z, answers_2018, tr_iter_tol) integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator type(time_type), intent(in) :: Time !< A FMS time type real, intent(in) :: conversion !< Conversion factor for tracer. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and native vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels. [CU ~> conc] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and native vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! with conversion to avoid accidentally having valid + !! values match missing values [CU ~> conc] logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating [CU ~> conc] ! Local variables 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. + !! native horizontal grid, with units that change + !! as the input data is interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [conc] then [CU ~> conc] 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. - - real :: PI_180 - integer :: id, jd, kd, jdp - integer :: i,j,k - real, dimension(:,:), allocatable :: x_in, y_in - 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, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. + !! on the original grid [conc] + real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes + integer :: i, j, k + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: pole ! The sum of tracer values at the pole [conc] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [conc] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np character(len=8) :: laynum type(horiz_interp_type) :: Interp @@ -633,17 +657,23 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t integer :: id_clock_read integer, dimension(4) :: fld_sz logical :: debug=.false. - logical :: spongeDataOngrid + logical :: is_ongrid 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 - 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 + real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [CU ~> conc] + real :: npoints ! The number of points in an average [nondim] + real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] integer :: turns integer :: verbosity @@ -655,6 +685,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + dtr_iter_stop = 1.0e-3*conversion + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / conversion + PI_180 = atan(1.0)/45. ans_2018 = .true.;if (present(answers_2018)) ans_2018 = answers_2018 @@ -664,15 +699,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_begin(id_clock_read) - call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_value) + call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_val_in) + missing_value = conversion*missing_val_in verbosity = MOM_get_verbosity() id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) - spongeDataOngrid = .false. - if (PRESENT(spongeOngrid)) spongeDataOngrid = spongeOngrid - if (.not. spongeDataOngrid) then + is_ongrid = .false. + if (PRESENT(spongeOngrid)) is_ongrid = spongeOngrid + if (.not. is_ongrid) then allocate(lon_in(id), lat_in(jd)) call get_axis_data(axes_data(1), lon_in) call get_axis_data(axes_data(2), lat_in) @@ -680,7 +716,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t allocate(z_in(kd), z_edges_in(kd+1)) - allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) call get_axis_data(axes_data(3), z_in) @@ -688,11 +725,11 @@ 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. + if (.not. is_ongrid) then max_lat = maxval(lat_in) add_np = .false. if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -718,23 +755,23 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else allocate(data_in(isd:ied,jsd:jed,kd)) endif - ! construct level cell boundaries as the mid-point between adjacent centers + + ! 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)) + do K=2,kd + 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) - - max_depth = maxval(G%bathyT) + G%Z_ref + max_depth = maxval(G%bathyT(:,:)) + G%Z_ref call max_across_PEs(max_depth) - if (z_edges_in(kd+1)5), turns=turns) ! Loop through each data level and interpolate to model grid. @@ -746,15 +783,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) - npole = npole+1.0 + npole = npole + 1.0 endif enddo if (npole > 0) then pole = pole / npole else - pole = missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -768,7 +805,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t 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 + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 tr_inp(i,j) = tr_inp(i,j) * conversion else @@ -783,7 +820,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif if (debug) then - call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') + call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) endif tr_out(:,:) = 0.0 @@ -814,15 +851,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. call sum_across_PEs(nPoints) call sum_across_PEs(varAvg) if (nPoints>0) then - varAvg = varAvg/real(nPoints) + varAvg = varAvg / real(nPoints) endif tr_out(:,:) = varAvg endif ; endif @@ -834,35 +872,36 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, & + answers_2018=answers_2018) ! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) +! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) ! endif -! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') - - tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) mask_z(:,:,k) = good2(:,:) + fill2(:,:) tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) endif enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) - do k=1,kd - do j=js,je - do i=is,ie - tr_z(i,j,k)=data_in(i,j,k) * conversion - 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 + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k) = data_in(i,j,k) * conversion + 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 endif + end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays.