From 70bfe8f0c48b22857db358f3033215ce5f0603a2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 2 Jun 2024 01:55:12 -0800 Subject: [PATCH 001/128] Spatially variable fields for MLE%Bodner (#617) * Spatially variable fields for MLE%Bodner - Allows reading in 2d fields for Cr and for MLD_decaying_Tfilt. * Finish the job? * Renamed one variable, fixed some units --- .../lateral/MOM_mixed_layer_restrat.F90 | 61 ++++++++++++++++--- 1 file changed, 52 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index e7ada31430..9f0061f104 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -15,6 +15,7 @@ module MOM_mixed_layer_restrat use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_intrinsic_functions, only : cuberoot +use MOM_io, only : MOM_read_data 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 @@ -98,11 +99,15 @@ module MOM_mixed_layer_restrat real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate !! during restratification, rescaled into thickness-based !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + logical :: MLD_grid !< If true, read a spacially varying field for MLD_decaying_Tfilt + logical :: Cr_grid !< If true, read a spacially varying field for Cr real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] - wpup_filtered !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + wpup_filtered, & !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + MLD_Tfilt_space, & !< Spatially varying time scale for MLD filter [T ~> s] + Cr_space !< Spatially varying Cr coefficient [nondim] !>@{ !! Diagnostic identifier @@ -887,11 +892,19 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d enddo ; enddo ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). - do j=js-1,je+1 ; do i=is-1,ie+1 - big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & - CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) - CS%MLD_filtered_slow(i,j) = big_H(i,j) - enddo ; enddo + if (CS%MLD_grid) then + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_Tfilt_space(i,j), dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + endif ! Estimate w'u' at h-points, with a floor to avoid division by zero later. if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then @@ -1050,7 +1063,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + psi_mag = ( ( ( CS%Cr_space(i,j) * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 @@ -1091,7 +1104,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + psi_mag = ( ( ( CS%Cr_space(i,j) * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 @@ -1549,6 +1562,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j + character(len=200) :: filename, inputdir, varname ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & @@ -1571,11 +1585,14 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%MLE_MLD_stretch = -9.e9 CS%use_Stanley_ML = .false. CS%use_Bodner = .false. + CS%MLD_grid = .false. + CS%Cr_grid = .false. call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters if (GV%nkml==0) then call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & @@ -1584,7 +1601,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, default=.false.) endif if (CS%use_Bodner) then - call get_param(param_file, mdl, "CR", CS%CR, & + call get_param(param_file, mdl, "CR", CS%Cr, & "The efficiency coefficient in eq 27 of Bodner et al., 2023.", & units="nondim", default=0.0) call get_param(param_file, mdl, "BODNER_NSTAR", CS%Nstar, & @@ -1638,6 +1655,32 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & "If true, turn on Stanley SGS T variance parameterization "// & "in ML restrat code.", default=.false.) + call get_param(param_file, mdl, "USE_CR_GRID", CS%Cr_grid, & + "If true, read in a spatially varying Cr field.", default=.false.) + call get_param(param_file, mdl, "USE_MLD_GRID", CS%MLD_grid, & + "If true, read in a spatially varying MLD_decaying_Tfilt field.", default=.false.) + if (CS%MLD_grid) then + call get_param(param_file, mdl, "MLD_TFILT_FILE", filename, & + "The path to the file containing the MLD_decaying_Tfilt fields.", & + default="") + call get_param(param_file, mdl, "MLD_TFILT_VAR", varname, & + "The variable name for MLD_decaying_Tfilt field.", & + default="MLD_tfilt") + filename = trim(inputdir) // "/" // trim(filename) + allocate(CS%MLD_Tfilt_space(G%isd:G%ied,G%jsd:G%jed), source=0.0) + call MOM_read_data(filename, varname, CS%MLD_Tfilt_space, G%domain, scale=US%s_to_T) + endif + allocate(CS%Cr_space(G%isd:G%ied,G%jsd:G%jed), source=CS%Cr) + if (CS%Cr_grid) then + call get_param(param_file, mdl, "CR_FILE", filename, & + "The path to the file containing the Cr fields.", & + default="") + call get_param(param_file, mdl, "CR_VAR", varname, & + "The variable name for Cr field.", & + default="Cr") + filename = trim(inputdir) // "/" // trim(filename) + call MOM_read_data(filename, varname, CS%Cr_space, G%domain) + endif call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & "If true, the MLE parameterization will use the mixed-layer "//& From b61022604a5ddde96be872cb6ec0d7ae9c58243b Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Sun, 2 Jun 2024 17:31:16 -0400 Subject: [PATCH 002/128] Flux through static ice-shelf to icebergs/new diagnostics (#622) * Added option to convert flux through static ice front into icebergs Added variables for the accumulated iceberg mass and heat flux due to calving from ice shelves (flux through the static ice front). These will be passed to the coupler and SIS2/iceberg module to initialize bergs. Also fixed the ice-shelf SMB override and reorganized ice-shelf post data calls so that they do not strictly have to be called at multiples of the ice velocity time step. * Added ice-shelf scalar diagnostics Added ice-shelf scalar diagnostics related to volume-above-floatation and surface/basal mass balance. Had to modify ice-shelf diag mediator to allow scalar diagnostics. * Fixed units for volume-above-floatation and Cp_ice. Renamed volume-above-floatation variable from 'vab' to 'vaf' * Fixed write_ice_shelf_energy call within subroutine solo_step_ice_shelf so that it is passing the correct arguments * Fixed syntax of calving units * Fixed units for ice shelf calving and scalar diagnostics --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 47 ++- src/core/MOM.F90 | 15 +- src/ice_shelf/MOM_ice_shelf.F90 | 286 ++++++++++++++++-- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 113 ++++++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 125 ++++++-- src/ice_shelf/MOM_ice_shelf_state.F90 | 10 +- 6 files changed, 541 insertions(+), 55 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 18bb0dbd06..45c14e73eb 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -55,6 +55,7 @@ module ocean_model_mod use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: Update_Surface_Waves use iso_fortran_env, only : int64 @@ -121,7 +122,10 @@ module ocean_model_mod !! formation in the ocean. melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice [J m-2]. OBLD => NULL(), & !< Ocean boundary layer depth [m]. - area => NULL() !< cell area of the ocean surface [m2]. + area => NULL(), & !< cell area of the ocean surface [m2]. + calving => NULL(), &!< The mass per unit area of the ice shelf to convert to + !! bergs [kg m-2]. + calving_hflx => NULL() !< Calving heat flux [W m-2]. type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -157,6 +161,8 @@ module ocean_model_mod !! ocean dynamics and forcing fluxes. real :: press_to_z !< A conversion factor between pressure and ocean depth, !! usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1]. + logical :: calve_ice_shelf_bergs = .false. !< If true, bergs are initialized according to + !! ice shelf flux through the ice front real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode !! with the barotropic and baroclinic dynamics, thermodynamics, @@ -221,7 +227,7 @@ module ocean_model_mod !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indices and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn, calve_ice_shelf_bergs) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -239,6 +245,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + logical, optional, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! Local variables real :: Rho0 ! The Boussinesq ocean density [R ~> kg m-3] real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] @@ -247,6 +255,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! 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 :: point_calving ! Equals calve_ice_shelf_bergs if calve_ice_shelf_bergs is present ! This include declares and sets the variable "version". # include "version_variable.h" @@ -274,11 +283,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas OS%Time = Time_in ; OS%Time_dyn = Time_in ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers ! initialization of ice shelf parameters and arrays. - + point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & - waves_CSp=OS%Waves) + waves_CSp=OS%Waves, calve_ice_shelf_bergs=point_calving) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -406,6 +415,13 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas endif + if (present(calve_ice_shelf_bergs)) then + if (calve_ice_shelf_bergs) then + call convert_shelf_state_to_ocean_type(Ocean_sfc, OS%Ice_shelf_CSp, OS%US) + OS%calve_ice_shelf_bergs=.true. + endif + endif + call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -668,6 +684,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US, & ! OS%fluxes%p_surf_full, OS%press_to_z) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + if (OS%calve_ice_shelf_bergs) call convert_shelf_state_to_ocean_type(Ocean_sfc,OS%Ice_shelf_CSp, OS%US) Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn call coupler_type_send_data(Ocean_sfc%fields, Time1) @@ -789,6 +806,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf (isc:iec,jsc:jec), & Ocean_sfc%v_surf (isc:iec,jsc:jec), & Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%calving(isc:iec,jsc:jec), & + Ocean_sfc%calving_hflx(isc:iec,jsc:jec), & Ocean_sfc%area (isc:iec,jsc:jec), & Ocean_sfc%melt_potential(isc:iec,jsc:jec), & Ocean_sfc%OBLD (isc:iec,jsc:jec), & @@ -799,6 +818,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf(:,:) = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models Ocean_sfc%v_surf(:,:) = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models Ocean_sfc%sea_lev(:,:) = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%calving(:,:) = 0.0 ! time accumulated ice sheet calving (kg m-2) passed to ice model + Ocean_sfc%calving_hflx(:,:) = 0.0 ! time accumulated ice sheet calving heat flux (W m-2) passed to ice model Ocean_sfc%frazil(:,:) = 0.0 ! time accumulated frazil (J/m^2) passed to ice model Ocean_sfc%melt_potential(:,:) = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model Ocean_sfc%OBLD(:,:) = 0.0 ! ocean boundary layer depth (m) @@ -932,6 +953,24 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ end subroutine convert_state_to_ocean_type +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine convert_shelf_state_to_ocean_type(Ocean_sfc, CS, US) + type(ocean_public_type), & + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd, i, j + + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) + + call ice_sheet_calving_to_ocean_sfc(CS,US,Ocean_sfc%calving(isc_bnd:iec_bnd,jsc_bnd:jec_bnd),& + Ocean_sfc%calving_hflx(isc_bnd:iec_bnd,jsc_bnd:jec_bnd)) + +end subroutine convert_shelf_state_to_ocean_type + !> This subroutine extracts the surface properties from the ocean's internal !! state and stores them in the ocean type returned to the calling ice model. !! It has to be separate from the ocean_initialization call because the coupler diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e6a42ef7a7..397a4e4059 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2007,7 +2007,8 @@ end subroutine step_offline !! initializing the ocean state variables, and initializing subsidiary modules subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num) + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num, & + calve_ice_shelf_bergs) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse @@ -2030,6 +2031,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS !! ensemble manager) + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -2043,6 +2046,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(MOM_restart_CS), pointer :: restart_CSp => NULL() character(len=4), parameter :: vers_num = 'v2.0' integer :: turns ! Number of grid quarter-turns + logical :: point_calving ! Initial state on the input index map real, allocatable :: u_in(:,:,:) ! Initial zonal velocities [L T-1 ~> m s-1] @@ -2903,6 +2907,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Consider removing this later? G%ke = GV%ke + if (use_ice_shelf) then + point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs + endif + if (CS%rotate_index) then G_in%ke = GV%ke @@ -2928,7 +2936,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & - Time_init, dirs%output_directory) + Time_init, dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) @@ -2987,7 +2995,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & deallocate(frac_shelf_in,mass_shelf_in) else if (use_ice_shelf) then - call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, dirs%output_directory) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, & + dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index b9640502d2..3f4c260eb4 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -8,11 +8,12 @@ module MOM_ice_shelf use MOM_constants, only : hlf 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_coms, only : num_PEs, reproducing_sum 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 : post_data=>post_IS_data, post_scalar_data=>post_IS_data_0d use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +use MOM_IS_diag_mediator, only : register_scalar_field=>register_MOM_IS_scalar_field use MOM_IS_diag_mediator, only : set_IS_axes_info, diag_ctrl, time_type use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end use MOM_IS_diag_mediator, only : set_IS_diag_mediator_grid @@ -51,7 +52,8 @@ module MOM_ice_shelf use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft -use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end, IS_dynamics_post_data +use MOM_ice_shelf_dynamics, only : volume_above_floatation, masked_var_grounded use MOM_ice_shelf_initialize, only : initialize_ice_thickness !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init @@ -75,6 +77,7 @@ module MOM_ice_shelf public shelf_calc_flux, initialize_ice_shelf, ice_shelf_end, ice_shelf_query public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces +public ice_sheet_calving_to_ocean_sfc ! 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 @@ -151,6 +154,8 @@ module MOM_ice_shelf !! will be called (note: GL_regularize and GL_couple !! should be exclusive) logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area + logical :: calve_ice_shelf_bergs=.false. !< If true, flux through a static ice front is converted + !! to point bergs real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [C ~> degC] real :: S0 !< Salinity at ocean surface in the restoring region [S ~> ppt]. @@ -206,7 +211,12 @@ module MOM_ice_shelf 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_shelf_sfc_mass_flux = -1 + id_shelf_sfc_mass_flux = -1, & + id_vaf = -1, id_g_adott = -1, id_f_adott = -1, id_adott = -1, & + id_bdott_melt = -1, id_bdott_accum = -1, id_bdott = -1, & + id_dvafdt = -1, id_g_adot = -1, id_f_adot = -1, id_adot = -1, & + id_bdot_melt = -1, id_bdot_accum = -1, id_bdot = -1, & + id_t_area = -1, id_g_area = -1, id_f_area = -1 !>@} type(external_field) :: mass_handle @@ -264,7 +274,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] - exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + exch_vel_s, & !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + tmp, & !< Temporary field used when calculating diagnostics [various] + dh_bdott, & !< Basal melt/accumulation over a time step, used for diagnostics [Z ~> m] + dh_adott !< Surface melt/accumulation over a time step, used for diagnostics [Z ~> m] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg s-1] @@ -333,6 +346,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) character(len=160) :: mesg ! The text of an error message integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 + real :: vaf0, vaf ! The previous and current volume above floatation [m3] + logical :: smb_diag=.false., bmb_diag=.false. ! Flags to calculate diagnostics related to surface/basal mass balance + real :: val ! Temporary value when calculating scalar diagnostics [various] if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -341,10 +357,21 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) G => CS%grid ; US => CS%US ISS => CS%ISS time_step = time_step_in + Itime_step = 1./time_step + if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & + CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0 ) smb_diag=.true. + if (CS%id_bdott>0 .or. CS%id_bdott_melt>0 .or. CS%id_bdott_accum>0 .or. & + CS%id_bdot >0 .or. CS%id_bdot_melt >0 .or. CS%id_bdot_accum >0) bmb_diag=.true. + + if (CS%active_shelf_dynamics .and. CS%id_dvafdt > 0) & !calculate previous volume above floatation + call volume_above_floatation(CS%dCS, G, ISS, vaf0) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed 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, & + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux(is:ie,js:je), CS%Time, & scale=US%kg_m2s_to_RZ_T) + call pass_var(fluxes_in%shelf_sfc_mass_flux, G%domain, complete=.true.) endif if (CS%rotate_index) then @@ -358,7 +385,6 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) fluxes => fluxes_in endif ! useful parameters - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed ZETA_N = CS%Zeta_N VK = CS%Vk RC = CS%Rc @@ -743,7 +769,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) @@ -757,7 +785,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) @@ -765,7 +795,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) scale=US%RZ_to_kg_m2) endif + if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) 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) @@ -778,13 +810,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & sfc_state%ocean_mass, coupled_GL) - Itime_step = 1./time_step do j=js,je ; do i=is,ie ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step enddo; enddo + + call IS_dynamics_post_data(time_step, Time, CS%dCS, G) endif if (CS%shelf_mass_is_dynamic) & @@ -816,9 +849,71 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) + !scalars + if (CS%active_shelf_dynamics) then + if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf) + if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val) + if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) + if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) + if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + tmp(:,:) = dh_adott(:,:) - tmp(:,:) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) + if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) + endif + endif + if (CS%id_bdott > 0 .or. CS%id_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val) + if (CS%id_bdott > 0) call post_scalar_data(CS%id_bdott,val ,CS%diag) + if (CS%id_bdot > 0) call post_scalar_data(CS%id_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_melt > 0 .or. CS%id_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag) + if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_accum > 0 .or. CS%id_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag) + if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_t_area > 0) then + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_t_area,val,CS%diag) + endif + if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_g_area > 0) then + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_g_area,val,CS%diag) + endif + if (CS%id_f_area > 0) then + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) + call post_scalar_data(CS%id_f_area,val,CS%diag) + endif + endif call disable_averaging(CS%diag) - call cpu_clock_end(id_clock_shelf) if (CS%rotate_index) then @@ -831,6 +926,48 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) end subroutine shelf_calc_flux +subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< Ice variable to integrate in arbitrary units [A ~> a] + real, intent(in) :: var_scale !< Dimensional scaling for variable to integrate [a A-1 ~> 1] + real, intent(out) :: var_out !< Variable integrated over the area of the ice sheet in arbitrary units [a m2] + real, dimension(SZI_(G),SZJ_(G)) :: var_cell !< Variable integrated over the ice-sheet area of each cell + !! in arbitrary units [a m2] + integer :: i,j + + var_cell(:,:)=0.0 + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0) var_cell(i,j) = (var(i,j) * var_scale) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + enddo; enddo + var_out = reproducing_sum(var_cell) +end subroutine integrate_over_ice_sheet_area + +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine ice_sheet_calving_to_ocean_sfc(CS,US,calving,calving_hflx) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:), intent(inout) :: calving !< The mass flux per unit area of the ice shelf + !! to convert to bergs [R Z T-1 ~> kg m-2 s-1]. + real, dimension(:,:), intent(inout) :: calving_hflx !< Calving heat flux [Q R Z T-1 ~> W m-2]. + ! Local variables + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. + integer :: is, ie, js, je + + G=>CS%Grid + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + calving = US%RZ_T_to_kg_m2s * ISS%calving(is:ie,js:je) + calving_hflx = US%QRZ_T_to_W_m2 * ISS%calving_hflx(is:ie,js:je) + + !CS%calve_ice_shelf_bergs=.true. + +end subroutine ice_sheet_calving_to_ocean_sfc + !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ice, debug) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -1243,7 +1380,7 @@ end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & - fluxes_in, sfc_state_in, solo_ice_sheet_in) + fluxes_in, sfc_state_in, solo_ice_sheet_in, calve_ice_shelf_bergs) 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 @@ -1261,6 +1398,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, !! intent is only inout to allow for halo updates. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing @@ -1671,6 +1810,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, units="m s-1", default=-1.0, scale=US%m_to_Z*US%T_to_s, & do_not_log=CS%ustar_shelf_from_vel) + if (present(calve_ice_shelf_bergs)) CS%calve_ice_shelf_bergs=calve_ice_shelf_bergs + ! Allocate and initialize state variables to default values call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS @@ -1726,6 +1867,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "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", conversion=US%Z_to_m) + + if (CS%calve_ice_shelf_bergs) then + call register_restart_field(ISS%calving, "shelf_calving", .true., CS%restart_CSp, & + "Calving flux from ice shelf into icebergs", "kg m-2", conversion=US%RZ_to_kg_m2) + call register_restart_field(ISS%calving_hflx, "shelf_calving_hflx", .true., CS%restart_CSp, & + "Calving heat flux from ice shelf into icebergs", "W m-2", conversion=US%QRZ_T_to_W_m2) + endif + 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", & @@ -1814,7 +1963,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, endif if (CS%shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, CS%Cp_ice, & Time_init, directory, solo_ice_sheet_in) call fix_restart_unit_scaling(US, unscaled=.true.) @@ -1879,6 +2028,47 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'ice shelf surface mass flux deposition from atmosphere', & 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif + !scalars (area integrated) + CS%id_vaf = register_scalar_field('ice_shelf_model', 'int_vaf', CS%diag%axesT1, CS%Time, & + 'Area integrated ice sheet volume above floatation', 'm3') + CS%id_adott = register_scalar_field('ice_shelf_model', 'int_a', CS%diag%axesT1, CS%Time, & + 'Area integrated (entire ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated change in grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_bdott = register_scalar_field('ice_shelf_model', 'int_b', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over ice shelves during a DT_THERM time step', 'm3') + CS%id_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over ice shelves during a DT_THERM a time step', 'm3') + CS%id_t_area = register_scalar_field('ice_shelf_model', 'tot_area', CS%diag%axesT1, CS%Time, & + 'Total area of entire ice-sheet', 'm2') + CS%id_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float', CS%diag%axesT1, CS%Time, & + 'Total area of floating ice shelves', 'm2') + CS%id_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground', CS%diag%axesT1, CS%Time, & + 'Total area of grounded ice sheet', 'm2') + !scalars (area integrated rates) + CS%id_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-sheet volume above floatation', 'm3 s-1') + CS%id_adot = register_scalar_field('ice_shelf_model', 'int_adot', CS%diag%axesT1, CS%Time, & + 'Area integrated (full ice sheet) rate of change in ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_bdot = register_scalar_field('ice_shelf_model', 'int_bdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over ice shelves', 'm3 s-1') + CS%id_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over ice shelves', 'm3 s-1') + call MOM_IS_diag_mediator_close_registration(CS%diag) if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) @@ -2241,6 +2431,13 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. integer :: is, ie, js, je, i, j + real :: vaf0, vaf ! The previous and current volume above floatation [m3] + logical :: smb_diag=.false. ! Flags to calculate diagnostics related to surface/basal mass balance + real :: val ! Temporary value when calculating scalar diagnostics [various] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + tmp, & ! Temporary field used when calculating diagnostics [various] + dh_adott_sum, & ! Surface melt/accumulation over a full time step, used for diagnostics [Z ~> m] + dh_adott ! Surface melt/accumulation over a partial time step, used for diagnostics [Z ~> m] G => CS%grid US => CS%US @@ -2262,6 +2459,15 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & + CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0) then + smb_diag=.true. + dh_adott(:,:) = 0.0 ; dh_adott_sum(:,:) = 0.0 ; tmp(:,:) = 0.0 + endif + + if (CS%id_dvafdt > 0) & !calculate previous volume above floatation + call volume_above_floatation(CS%dCS, G, ISS, vaf0) + do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2275,7 +2481,10 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + if (smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & + (ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je)) remaining_time = remaining_time - time_step @@ -2284,23 +2493,62 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & + must_update_vel=update_ice_vel) enddo - call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & - time_step=real_to_time(US%T_to_s*time_step) ) + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, time_step=time_interval) + do j=js,je ; do i=is,ie ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step enddo; enddo call enable_averages(full_time_step, Time, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) - if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h ,ISS%area_shelf_h,CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf ,ISS%h_shelf ,CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf ,ISS%dhdt_shelf ,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask ,ISS%hmask ,CS%diag) + if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf) + if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Ifull_time_step,CS%diag) !d(vaf)/dt + if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott_sum, US%Z_to_m, val) + if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) + if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Ifull_time_step,CS%diag) + endif + if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott_sum,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) + if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Ifull_time_step,CS%diag) + endif + if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott_sum,tmp) + tmp(:,:) = dh_adott_sum(:,:) - tmp(:,:) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) + if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Ifull_time_step,CS%diag) + endif + if (CS%id_t_area > 0) then + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_t_area,val,CS%diag) + endif + if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_g_area > 0) then + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + call post_scalar_data(CS%id_g_area,val,CS%diag) + endif + if (CS%id_f_area > 0) then + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) + call post_scalar_data(CS%id_f_area,val,CS%diag) + endif + endif call disable_averaging(CS%diag) + call IS_dynamics_post_data(full_time_step, Time, CS%dCS, G) end subroutine solo_step_ice_shelf !> \namespace mom_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 42fa63fd95..5ecfb9e788 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -27,6 +27,7 @@ module MOM_IS_diag_mediator public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid public MOM_IS_diag_mediator_close_registration, get_diag_time_end public MOM_diag_axis_init, register_static_field_infra +public register_MOM_IS_scalar_field, post_IS_data_0d !> 2D/3D axes type to contain 1D axes handles and pointers to masks type, public :: axesType @@ -344,6 +345,36 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) end subroutine post_IS_data +!> Make a real ice shelf scalar diagnostic available for averaging or output +subroutine post_IS_data_0d(diag_field_id, field, diag_cs, is_static) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + ! Local variables + real :: locfield ! The field being offered in arbitrary unscaled units [a] + logical :: used, is_stat + type(diag_type), pointer :: diag => null() + + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_0d: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + + locfield = field + if (diag%conversion_factor /= 0.) & + locfield = locfield * diag%conversion_factor + + if (is_stat) then + used = send_data_infra(diag%fms_diag_id, locfield) + elseif (diag_cs%ave_enabled) then + used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end) + endif +end subroutine post_IS_data_0d + !> Enable the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) @@ -429,22 +460,25 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(out):: err_msg !< String into which an error message might be - !! placed (not used in MOM?) + !! placed (not used in MOM?) character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not - !! be interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables character(len=240) :: mesg - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] integer :: primary_id, fms_id type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used ! to regulate diagnostic output @@ -513,6 +547,71 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & end function register_MOM_IS_diag_field +!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one scalar. +function register_MOM_IS_scalar_field(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, conversion) result (register_scalar_field) + integer :: register_scalar_field !< The returned diagnostic handle + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axesType), intent(in) :: axes !< The axis group for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + + ! Local variables + character(len=240) :: mesg + real :: MOM_missing_value + integer :: primary_id, fms_id + type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used + ! to regulate diagnostic output + type(diag_type), pointer :: diag => NULL() + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + primary_id = -1 + + fms_id = register_diag_field_infra(module_name, field_name, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg) + + if (fms_id > 0) then + primary_id = get_new_diag_id(diag_cs) + diag => diag_cs%diags(primary_id) + diag%fms_diag_id = fms_id + if (len(field_name) > len(diag%name)) then + diag%name = field_name(1:len(diag%name)) + else ; diag%name = field_name ; endif + + if (present(conversion)) diag%conversion_factor = conversion + endif + + if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (primary_id > 0) then + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + endif + write(diag_CS%doc_unit, '(a)') trim(mesg) + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + endif + + register_scalar_field = primary_id + +end function register_MOM_IS_scalar_field + !> Registers a static diagnostic, returning an integer handle function register_MOM_IS_static_field(module_name, field_name, axes, & long_name, units, missing_value, range, mask_variant, standard_name, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ec49081baf..27cb4721bf 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -34,9 +34,10 @@ module MOM_ice_shelf_dynamics #include -public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf, IS_dynamics_post_data public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy -public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask, volume_above_floatation +public masked_var_grounded ! 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 @@ -133,6 +134,7 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. + real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction @@ -388,7 +390,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, & +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, Cp_ice, & Input_start_time, directory, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time @@ -400,6 +402,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. + real, intent(in) :: Cp_ice !< Heat capacity of ice [Q C-1 ~> J kg-1 degC-1] type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether @@ -552,7 +555,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) - + CS%Cp_ice = Cp_ice !Heat capacity of ice (J kg-1 K-1), needed for heat flux of any bergs calved from + !the ice shelf and for ice sheet temperature solver !for write_ice_shelf_energy ! Note that the units of CS%Timeunit are the MKS units of [s]. call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & @@ -774,6 +778,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + + !Update these variables so that they are nonzero in case + !IS_dynamics_post_data is called before update_ice_shelf + if (CS%id_taudx_shelf>0 .or. CS%id_taudy_shelf>0) & + call calc_shelf_driving_stress(CS, ISS, G, US, CS%taudx_shelf, CS%taudy_shelf, CS%OD_av) + if (CS%id_taub>0) & + call calc_shelf_taub(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) + if (CS%id_visc_shelf>0) & + call calc_shelf_visc(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) endif if (new_sim) then @@ -850,7 +863,8 @@ end function ice_time_step_CFL !> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the !! ice shelf dynamics. -subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) +subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, calve_ice_shelf_bergs, & + ocean_mass, coupled_grounding, must_update_vel) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -858,17 +872,14 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: calve_ice_shelf_bergs !< To convert ice flux through front + !! to bergs real, dimension(SZDI_(G),SZDJ_(G)), & optional, intent(in) :: ocean_mass !< If present this is the mass per unit area !! of the ocean [R Z ~> kg m-2]. logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is !! determined by coupled ice-ocean dynamics logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. - real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity - !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, - !! [R L1 T-1 ~> Pa s m-1] integer :: iters logical :: update_ice_vel, coupled_GL @@ -879,7 +890,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! if (CS%advect_shelf) then - call ice_shelf_advect(CS, ISS, G, time_step, Time) + call ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) if (CS%alternate_first_direction_IS) then CS%first_direction_IS = modulo(CS%first_direction_IS+1,2) CS%first_dir_restart_IS = real(CS%first_direction_IS) @@ -897,12 +908,71 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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) + CS%elapsed_velocity_time = 0.0 endif ! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then - call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) +end subroutine update_ice_shelf + +subroutine volume_above_floatation(CS, G, ISS, vaf) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(out) :: vaf !< area integrated volume above floatation [m3] + real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [m3] + integer :: is,ie,js,je,i,j + real :: rhoi_rhow, rhow_rhoi + + if (CS%GL_couple) & + call MOM_error(FATAL, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..") + + vaf_cell(:,:)=0.0 + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + rhow_rhoi = CS%density_ocean_avg / CS%density_ice + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + do j = js,je; do i = is,ie + if (ISS%hmask(i,j)>0) then + if (CS%bed_elev(i,j) <= 0) then + !grounded above sea level + vaf_cell(i,j)= (ISS%h_shelf(i,j) * G%US%Z_to_m) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + else + !grounded if vaf_cell(i,j) > 0 + vaf_cell(i,j) = (max(ISS%h_shelf(i,j) - rhow_rhoi * CS%bed_elev(i,j), 0.0) * G%US%Z_to_m) * & + (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + endif + endif + enddo; enddo + + vaf = reproducing_sum(vaf_cell) +end subroutine volume_above_floatation + +!> multiplies a variable with the ice sheet grounding fraction +subroutine masked_var_grounded(G,CS,var,varout) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< variable in + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: varout ! Ice shelf dynamics post_data calls +subroutine IS_dynamics_post_data(time_step, Time, CS, G) + real :: time_step !< Length of time for post data averaging [T ~> s]. + type(time_type), intent(in) :: Time !< The current model time + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] + call enable_averages(time_step, 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) @@ -931,7 +1001,6 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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) @@ -939,11 +1008,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled ! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) call disable_averaging(CS%diag) - - CS%elapsed_velocity_time = 0.0 - endif - -end subroutine update_ice_shelf +end subroutine IS_dynamics_post_data !> Writes the total ice shelf kinetic energy and mass to an ascii file subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) @@ -1080,14 +1145,15 @@ end subroutine write_ice_shelf_energy !> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. !! Additionally, it will update the volume of ice in partially-filled cells, and update !! hmask accordingly -subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time - + logical, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! 3/8/11 DNG ! @@ -1155,6 +1221,23 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) if (CS%calve_to_mask) then call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) endif + elseif (calve_ice_shelf_bergs) then + !advect the front to create partially-filled cells + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) + !add mass of the partially-filled cells to calving field, which is used to initialize icebergs + !Then, remove the partially-filled cells from the ice shelf + ISS%calving(:,:)=0.0 + ISS%calving_hflx(:,:)=0.0 + do j=jsc,jec; do i=isc,iec + if (ISS%hmask(i,j)==2) then + ISS%calving(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) / time_step + ISS%calving_hflx(i,j) = (CS%Cp_ice * CS%t_shelf(i,j)) * & + ((ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j))) + ISS%h_shelf(i,j) = 0.0; ISS%area_shelf_h(i,j) = 0.0; ISS%hmask(i,j) = 0.0 + endif + enddo; enddo endif do j=jsc,jec; do i=isc,iec diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index e6be780073..d789c08bd4 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -46,9 +46,13 @@ module MOM_ice_shelf_state tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. - tfreeze => NULL() !< The freezing point potential temperature + tfreeze => NULL(), & !< The freezing point potential temperature !! at the ice-ocean interface [C ~> degC]. + !only active when calve_ice_shelf_bergs=true: + calving => NULL(), & !< The mass flux per unit area of the ice shelf to convert to + !! bergs [R Z T-1 ~> kg m-2 s-1]. + calving_hflx => NULL() !< Calving heat flux [Q R Z T-1 ~> W m-2]. end type ice_shelf_state contains @@ -80,6 +84,8 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%tflux_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%tfreeze(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving_hflx(isd:ied,jsd:jed), source=0.0 ) end subroutine ice_shelf_state_init @@ -94,6 +100,8 @@ subroutine ice_shelf_state_end(ISS) deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) deallocate(ISS%tfreeze) + deallocate(ISS%calving, ISS%calving_hflx) + deallocate(ISS) end subroutine ice_shelf_state_end From d8e714e283364c29a0e5b8dcba514f05216ac65e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Apr 2024 09:09:08 -0400 Subject: [PATCH 003/128] +(*)Refactor Idealize_Hurricane Refactored the Idealized_Hurricane module to clean up strange or unscaled variable units and eliminate dimensional scaling factors with the latest answer dates. This includes the introduction of 18 new runtime variables to replace hard-coded dimensional constants and two runtime logical flags to reproduce existing bugs. An inconsistency in the sign convention for the distance from the hurricane center with idealized_hurricane_wind_forcing in (the probably not yet used) single column mode was also corrected. Also added descriptions with units for all the variables in this module. By default or with appropriate parameter settings all answers are bitwise identical. --- src/user/Idealized_Hurricane.F90 | 564 +++++++++++++++++++++---------- 1 file changed, 380 insertions(+), 184 deletions(-) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 0c9d5cd330..c47366b23c 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -13,10 +13,9 @@ module Idealized_hurricane ! The T/S initializations have been removed since they are redundant ! w/ T/S initializations in CVMix_tests (which should be moved ! into the main state_initialization to their utility -! for multiple example cases).. +! for multiple example cases). ! To do ! 1. Remove the legacy SCM_idealized_hurricane_wind_forcing code -! 2. Make the hurricane-to-background wind transition a runtime parameter ! use MOM_error_handler, only : MOM_error, FATAL @@ -49,6 +48,10 @@ module Idealized_hurricane real :: pressure_ambient !< Pressure at surface of ambient air [R L2 T-2 ~> Pa] real :: pressure_central !< Pressure at surface at hurricane center [R L2 T-2 ~> Pa] real :: rad_max_wind !< Radius of maximum winds [L ~> m] + real :: rad_edge !< Radius of the edge of the hurricane, normalized by + !! the radius of maximum winds [nondim] + real :: rad_ambient !< Radius at which the winds are at their ambient background values, + !! normalized by the radius of maximum winds [nondim] real :: max_windspeed !< Maximum wind speeds [L T-1 ~> m s-1] real :: hurr_translation_spd !< Hurricane translation speed [L T-1 ~> m s-1] real :: hurr_translation_dir !< Hurricane translation direction [radians] @@ -60,34 +63,60 @@ module Idealized_hurricane real :: Hurr_cen_X0 !< The initial x position of the hurricane !! This experiment is conducted in a Cartesian !! grid and this is assumed to be in meters [L ~> m] - real :: Holland_A !< Parameter 'A' from the Holland formula [nondim] real :: Holland_B !< Parameter 'B' from the Holland formula [nondim] - real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) - !! for the Holland prorfile calculation [R L2 T-2 ~> Pa] logical :: relative_tau !< A logical to take difference between wind !! and surface currents to compute the stress integer :: answer_date !< The vintage of the expressions in the idealized hurricane !! test case. Values below 20190101 recover the answers !! from the end of 2018, while higher values use expressions !! that are rescalable and respect rotational symmetry. + ! Parameters used in a simple wind-speed dependent expression for C_drag + real :: Cd_calm !< The drag coefficient with weak relative winds [nondim] + real :: calm_speed !< The relative wind speed below which the drag coefficient takes its + !! calm value [L T-1 ~> m s-1] + real :: Cd_windy !< The drag coefficient with strong relative winds [nondim] + real :: windy_speed !< The relative wind speed below which the drag coefficient takes its + !! windy value [L T-1 ~> m s-1] + real :: dCd_dU10 !< The partial derivative of the drag coefficient times 1000 with the 10 m + !! wind speed for intermediate wind speeds [T L-1 ~> s m-1] + real :: Cd_intercept !< The zero-wind intercept times 1000 of the linear fit for the drag + !! coefficient for the intermediate speeds where there is a linear + !! dependence on the 10 m wind speed [nondim] + + ! Parameters used to set the inflow angle as a function of radius and maximum wind speed + real :: A0_0 !< The zero-radius, zero-speed intercept of the axisymmetric inflow angle [degrees] + real :: A0_Rnorm !< The normalized radius dependence of the axisymmetric inflow angle [degrees] + real :: A0_speed !< The maximum wind speed dependence of the axisymmetric inflow angle + !! [degrees T L-1 ~> degrees s m-1] + real :: A1_0 !< The zero-radius, zero-speed intercept of the normalized inflow angle + !! asymmetry [degrees] + real :: A1_Rnorm !< The normalized radius dependence of the normalized inflow angle asymmetry [degrees] + real :: A1_speed !< The translation speed dependence of the normalized inflow angle asymmetry + !! [degrees T L-1 ~> degrees s m-1] + real :: P1_0 !< The zero-radius, zero-speed intercept of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_Rnorm !< The normalized radius dependence of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_speed !< The translation speed dependence of the angle difference between the + !! translation direction and the inflow direction [degrees T L-1 ~> degrees s m-1] ! Parameters used if in SCM (single column model) mode - logical :: SCM_mode !< If true this being used in Single Column Model mode - logical :: BR_BENCH !< A "benchmark" configuration (which is meant to - !! provide identical wind to reproduce a previous - !! experiment, where that wind formula contained - !! an error) + logical :: SCM_mode !< If true this being used in Single Column Model mode + logical :: edge_taper_bug !< If true and SCM_mode is true, use a bug that does all of the tapering + !! and inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT + !! as though they were at RAD_EDGE. + real :: f_column !< Coriolis parameter used in the single column mode idealized + !! hurricane wind profile [T-1 ~> s-1] + logical :: BR_Bench !< A "benchmark" configuration (which is meant to + !! provide identical wind to reproduce a previous + !! experiment, where that wind formula contained an error) real :: dy_from_center !< (Fixed) distance in y from storm center path [L ~> m] - ! Par - real :: PI !< Mathematical constant - real :: Deg2Rad !< Mathematical constant + real :: pi !< The circumference of a circle divided by its diameter [nondim] + real :: Deg2Rad !< The conversion factor from degrees to radians [radian degree-1] end type -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "idealized_hurricane" !< This module's name. contains @@ -102,8 +131,11 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) ! Local variables real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: C ! A temporary variable [nondim] + real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: continuous_Cd ! If true, use a continuous form for the simple drag coefficient as a + ! function of wind speed with the idealized hurricane. When this is false, the + ! linear shape for the mid-range wind speeds is specified separately. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -132,16 +164,22 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & "Central pressure used in the idealized hurricane wind profile.", & units='Pa', default=96800., scale=US%Pa_to_RL2_T2) - call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & - CS%rad_max_wind, "Radius of maximum winds used in the "//& - "idealized hurricane wind profile.", & + 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) + call get_param(param_file, mdl, "IDL_HURR_RAD_EDGE", CS%rad_edge, & + "Radius of the edge of the hurricane, normalized by the radius of maximum winds.", & + units='nondim', default=10.0) + call get_param(param_file, mdl, "IDL_HURR_RAD_AMBIENT", CS%rad_ambient, & + "Radius at which the winds are at their ambient background values, "//& + "normalized by the radius of maximum winds.", & + units='nondim', default=CS%rad_edge+2.0) 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) + "Maximum wind speed used in the idealized hurricane wind profile.", & + units='m/s', default=65., scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & - "Translation speed of hurricane used in the idealized "//& - "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) + "Translation speed of hurricane used in the idealized 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.", & @@ -156,17 +194,67 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Current relative stress switch used in the idealized hurricane wind profile.", & default=.false.) + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_0", CS%A0_0, & + "The zero-radius asymmetry, zero-speed intercept of the axisymmetric inflow "//& + "angle for the parametric idealized hurricane.", & + default=-14.33, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_RNORM", CS%A0_Rnorm, & + "The normalized radius dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.9, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_MAX_SPEED", CS%A0_speed, & + "The maximum wind speed dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.09, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_0", CS%A1_0, & + "The zero-radius, zero-speed intercept of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.14, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_RNORM", CS%A1_Rnorm, & + "The normalized radius dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.04, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_TR_SPEED", CS%A1_speed, & + "The translation speed dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.05, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_0", CS%P1_0, & + "The zero-radius, zero-speed intercept of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=85.31, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_RNORM", CS%P1_Rnorm, & + "The normalized radius dependence of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=6.88, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_TR_SPEED", CS%P1_speed, & + "The translation speed dependence of the angle difference between the "//& + "translation direction and the inflow direction"//& + "for the parametric idealized hurricane.", & + default=-9.60, units="degrees s m-1", scale=US%L_T_to_m_s) + ! Parameters for SCM mode - call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & + 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.", default=.false.) - call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & + call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_mode, & "Single Column mode switch used in the SCM idealized hurricane wind profile.", & default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM_EDGE_TAPER_BUG", CS%edge_taper_bug, & + "If true and IDL_HURR_SCM is true, use a bug that does all of the tapering and "//& + "inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT as though "//& + "they were at RAD_EDGE.", & + default=CS%SCM_mode, do_not_log=.not.CS%SCM_mode) !### Change the default to false. + if (.not.CS%SCM_mode) CS%edge_taper_bug = .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) + "Y distance of station used in the SCM idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_SCM_CORIOLIS", CS%f_column, & + "Coriolis parameter used in the single column mode idealized hurricane wind profile.", & + units='s-1', default=5.5659e-05, scale=US%T_to_s, do_not_log=.not.CS%BR_Bench) ! (CS%SCM_mode) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -176,6 +264,48 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "values use expressions that are rescalable and respect rotational symmetry.", & default=default_answer_date) + ! Parameters for the simple Cdrag expression + call get_param(param_file, mdl, "IDL_HURR_CD_CALM", CS%Cd_calm, & + "The drag coefficient with weak relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.2e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_CALM_SPEED", CS%calm_speed, & + "The relative wind speed below which the drag coefficient takes its calm value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=11.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY", CS%Cd_windy, & + "The drag coefficient with strong relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.8e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY_SPEED", CS%windy_speed, & + "The relative wind speed below which the drag coefficient takes its windy value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=20.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_CONTINUOUS", continuous_Cd, & + "If true, use a continuous form for the simple drag coefficient as a function of "//& + "wind speed with the idealized hurricane. When this is false, the linear shape "//& + "for the mid-range wind speeds is specified separately.", & + default=.false.) + call get_param(param_file, mdl, "IDL_HURR_CD_DCD_DU10", CS%dCd_dU10, & + "The partial derivative of the drag coefficient times 1000 with the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="s m-1", default=0.065, scale=US%L_T_to_m_s, do_not_log=continuous_Cd) + call get_param(param_file, mdl, "IDL_HURR_CD_INTERCEPT", CS%Cd_intercept, & + "The zero-wind intercept times 1000 of the linear fit for the drag coefficient "//& + "for the intermediate speeds where there is a linear dependence on the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="nondim", default=0.49, do_not_log=continuous_Cd) + if (continuous_Cd) then + if (CS%windy_speed > CS%calm_speed) then + CS%dCd_dU10 = (CS%Cd_windy - CS%Cd_calm) / (CS%windy_speed - CS%calm_speed) + CS%Cd_intercept = CS%Cd_calm - CS%dCd_dU10 * CS%calm_speed + else + CS%dCd_dU10 = 0.0 + CS%Cd_intercept = CS%Cd_windy + endif + endif + + ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default ! value should be consistent with the rest of the model. @@ -189,9 +319,9 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "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 - endif + if (CS%rad_edge >= CS%rad_ambient) call MOM_error(FATAL, & + "idealized_hurricane_wind_init: IDL_HURR_RAD_AMBIENT must be larger than IDL_HURR_RAD_EDGE.") + dP = CS%pressure_ambient - CS%pressure_central if (CS%answer_date < 20190101) then C = CS%max_windspeed / sqrt( US%R_to_kg_m3 * dP ) @@ -199,8 +329,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) else CS%Holland_B = CS%max_windspeed**2 * CS%rho_a * exp(1.0) / dP endif - CS%Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B - CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*dP end subroutine idealized_hurricane_wind_init @@ -225,6 +353,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) real :: fbench !< The benchmark 'f' value [T-1 ~> s-1] real :: fbench_fac !< A factor that is set to 0 to use the !! benchmark 'f' value [nondim] + real :: km_to_L !< The conversion factor from the units of latitude to L [L km-1 ~> 1e3] real :: rel_tau_fac !< A factor that is set to 0 to disable !! current relative stress calculation [nondim] @@ -234,6 +363,8 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + km_to_L = 1.0e3*US%m_to_L + ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) @@ -252,7 +383,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) if (CS%BR_Bench) then ! f reset to value used in generated wind for benchmark test - fbench = 5.5659e-05 * US%T_to_s + fbench = CS%f_column fbench_fac = 0.0 else fbench = 0.0 @@ -267,17 +398,17 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) Vocn = 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC else - Vocn =0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& - (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC + Vocn = 0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC endif f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCu(I,j)*1000.*US%m_to_L - YC - XX = G%geoLonCu(I,j)*1000.*US%m_to_L - XC + YY = G%geoLatCu(I,j)*km_to_L - YC + XX = G%geoLonCu(I,j)*km_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%taux(I,j) = G%mask2dCu(I,j) * TX @@ -297,11 +428,11 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCv(i,J)*1000.*US%m_to_L - YC - XX = G%geoLonCv(i,J)*1000.*US%m_to_L - XC + YY = G%geoLatCv(i,J)*km_to_L - YC + XX = G%geoLonCv(i,J)*km_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%tauy(i,J) = G%mask2dCv(i,J) * TY @@ -347,30 +478,41 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind profile terms real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: radius ! The distance from the hurricane center [L ~> m] - real :: radius10 ! 10 times the distance from the hurricane center [L ~> m] + real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] real :: radius_km ! The distance from the hurricane center, perhaps in km [L ~> m] or [1000 L ~> km] - real :: radiusB - real :: tmp ! A temporary variable [R L T-1 ~> kg m-2 s-1] real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] real :: du ! The difference between the zonal 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] real :: dv ! The difference between the meridional 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] - real :: CD + real :: Cd ! The drag coefficient [nondim] + ! These variables with weird units are only used with pre-20240501 expressions + real :: radiusB ! A rescaled radius in m raised to the variable power CS%Holland_B [m^B] + real :: Holland_A ! Parameter 'A' from the Holland formula, in units of m raised to Holland_B [m^B] + real :: Holland_AxBxDP ! 'A' x 'B' x (Pressure Ambient-Pressure central) + ! for the Holland profile calculation [m^B R L2 T-2 ~> m^B Pa] + real :: tmp ! A temporary variable [m^B R L T-1 ~> m^B kg m-2 s-1] + ! These variables are used with expressions from 20240501 or later + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: tmpA ! A temporary variable [R L2 T-2 ~> Pa] + real :: tmpB ! A temporary variable [R L T-1 ~> kg m-2 s-1] + real :: rad_max_rad_B ! The radius of maximum wind divided by the distance from the center raised + ! to the power of Holland_B [nondim] + real :: rad_rad_max ! The radius normalized by the radius of maximum winds [nondim] !Wind angle variables - real :: Alph !< The resulting inflow angle (positive outward) - real :: Rstr - real :: A0 - real :: A1 - real :: P1 - real :: Adir + real :: Alph ! The wind inflow angle (positive outward) [radians] + real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] + real :: A0 ! The axisymmetric inflow angle [degrees] + real :: A1 ! The inflow angle asymmetry [degrees] + real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] + real :: Adir ! The angle of the direction from the center to a point [radians] real :: V_TS ! Meridional hurricane translation speed [L T-1 ~> m s-1] real :: U_TS ! Zonal hurricane translation speed [L T-1 ~> m s-1] - ! Implementing Holland (1980) parameteric wind profile + ! Implementing Holland (1980) parametric wind profile radius = SQRT(XX**2 + YY**2) + rad_rad_max = radius / CS%rad_max_wind - !/ BGR ! rkm - r converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must @@ -382,17 +524,24 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! if not comparing to benchmark, then use correct Holland prof. radius_km = radius endif - radiusB = (US%L_to_m*radius)**CS%Holland_B !/ - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. + ! Calculate U10 in the interior (inside of the hurricane edge radius), + ! while adjusting U10 to 0 outside of the ambient wind radius. if (CS%answer_date < 20190101) then - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then - U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius10 = CS%rad_max_wind*10. + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius10 = CS%rad_max_wind*CS%rad_edge if (CS%BR_Bench) then radius_km = radius10/1000. else @@ -400,24 +549,64 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx endif radiusB = (US%L_to_m*radius10)**CS%Holland_B - U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = (sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf) & - * (15. - radius/CS%rad_max_wind)/5. + * (CS%rad_ambient - radius/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) else U10 = 0. endif - else ! This is mathematically equivalent to that is above but more accurate. - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + elseif (CS%answer_date < 20240501) then + ! This is mathematically equivalent to that is above but more accurate. + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (CS%Holland_AxBxDP * exp(-CS%Holland_A/radiusB)) / & - ( tmp + sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius_km = 10.0 * CS%rad_max_wind + U10 = (Holland_AxBxDP * exp(-Holland_A/radiusB)) / & + ( tmp + sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind if (CS%BR_Bench) radius_km = radius_km/1000. - radiusB = (10.0*US%L_to_m*CS%rad_max_wind)**CS%Holland_B + radiusB = (CS%rad_edge*US%L_to_m*CS%rad_max_wind)**CS%Holland_B tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (3.0 - radius/(5.0*CS%rad_max_wind)) * (CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) ) / & - ( tmp + sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = ((CS%rad_ambient/(CS%rad_ambient - CS%rad_edge)) - & + radius/((CS%rad_ambient - CS%rad_edge)*CS%rad_max_wind)) * & + (Holland_AxBxDp*exp(-Holland_A/radiusB) ) / & + ( tmp + sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + else + U10 = 0.0 + endif + else + ! This is mathematically equivalent to the expressions above, but allows for full + ! dimensional consistency testing. + dP = CS%pressure_ambient - CS%pressure_central + if ( (rad_rad_max > 0.001) .and. (rad_rad_max <= CS%rad_edge) ) then + rad_max_rad_B = (rad_rad_max)**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ( tmpA * exp(-rad_max_rad_B) ) / & + ( tmpB + sqrt( (tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) + elseif ( (rad_rad_max > CS%rad_edge) .and. (rad_rad_max < CS%rad_ambient) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind + if (CS%BR_Bench) radius_km = radius_km * 0.001 + rad_max_rad_B = CS%rad_edge**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ((CS%rad_ambient - rad_rad_max) * ( tmpA * exp(-rad_max_rad_B) )) / & + ((CS%rad_ambient - CS%rad_edge) * & + ( tmpB + sqrt((tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) ) else U10 = 0.0 endif @@ -429,45 +618,42 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10., radius / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0*(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31) * CS%Deg2Rad - ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) - if ( (radius > 10.*CS%rad_max_wind) .and.& - (radius < 15.*CS%rad_max_wind) ) then - ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. - elseif (radius > 15.*CS%rad_max_wind) then - ALPH = 0.0 + RSTR = min(CS%rad_edge, rad_rad_max) + if (CS%answer_date < 20240501) then + A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 + A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) + P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%Deg2Rad + ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) + if ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + ALPH = ALPH*(CS%rad_ambient - rad_rad_max) / (CS%rad_ambient - CS%rad_edge) + elseif (radius > CS%rad_ambient*CS%rad_max_wind) then ! This should be >= to avoid a jump at CS%rad_ambient + ALPH = 0.0 + endif + ALPH = ALPH * CS%Deg2Rad + else + A0 = (CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed) + CS%A0_0 + A1 = -A0*((CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd) + CS%A1_0) + P1 = ((CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd) + CS%P1_0) * CS%Deg2Rad + ALPH = (A0 - A1*cos((CS%hurr_translation_dir- Adir) - P1) ) * CS%Deg2Rad + if (rad_rad_max > CS%rad_edge) & + ALPH = ALPH * (max(CS%rad_ambient - rad_rad_max, 0.0) / (CS%rad_ambient - CS%rad_edge)) endif - ALPH = ALPH * CS%Deg2Rad ! Calculate translation speed components U_TS = CS%hurr_translation_spd * 0.5*cos(CS%hurr_translation_dir) V_TS = CS%hurr_translation_spd * 0.5*sin(CS%hurr_translation_dir) ! Set output (relative) winds - dU = U10*sin(Adir-CS%Pi-Alph) - Uocn + U_TS + dU = U10*sin(Adir-CS%pi-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) du10 = sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 - else - Cd = (0.49 + 0.065*US%L_T_to_m_s*dU10)*1.e-3 - endif - else - Cd = 1.8e-3 - endif + Cd = simple_wind_scaled_Cd(u10, du10, CS) ! Compute stress vector - TX = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dU - TY = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dV - + TX = US%L_to_Z * CS%rho_a * Cd * du10 * dU + TY = US%L_to_Z * CS%rho_a * Cd * du10 * dV end subroutine idealized_hurricane_wind_profile !> This subroutine is primarily needed as a legacy for reproducing answers. @@ -484,24 +670,34 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: pie, Deg2Rad real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] - real :: A, B, C ! For wind profile expression + real :: A ! The radius of the maximum winds raised to the power given by B, used in the + ! wind profile expression, in [km^B] + real :: B ! A power used in the wind profile expression [nondim] + real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] real :: rad ! The distance from the hurricane center [L ~> m] + real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] real :: xx ! x-position [L ~> m] - real :: t0 !for location + real :: t0 ! Time at which the eye crosses the origin [T ~> s] real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: rB - real :: Cd ! Air-sea drag coefficient + real :: rB ! The distance from the center raised to the power given by B, in [m^B] + ! or [km^B] if BR_Bench is true. + real :: Cd ! Air-sea drag coefficient [nondim] real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] - !Wind angle variables - real :: Alph,Rstr, A0, A1, P1, Adir, transdir + ! Wind angle variables + real :: Alph ! The wind inflow angle (positive outward) [radians] + real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] + real :: A0 ! The axisymmetric inflow angle [degrees] + real :: A1 ! The inflow angle asymmetry [degrees] + real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] + real :: Adir ! The angle of the direction from the center to a point [radians] + real :: transdir ! Translation direction [radians] real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] - logical :: BR_Bench + ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -509,46 +705,46 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) - pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. - !/ BR + ! Implementing Holland (1980) parameteric wind profile - !------------------------------------------------------| - BR_Bench = .true. !true if comparing to LES runs | - t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| - transdir = pie !translation direction (-x) | - !------------------------------------------------------| + !------------------------------------------------------------| + t0 = 129600.*US%s_to_T ! TC 'eye' crosses (0,0) at 36 hours | + transdir = CS%pi ! translation direction (-x) | + !------------------------------------------------------------| dP = CS%pressure_ambient - CS%pressure_central if (CS%answer_date < 20190101) then C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) - if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + if (CS%BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test B = C**2 * 1.2 * exp(1.0) endif - elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) else - B = (CS%max_windspeed**2 /dP ) * CS%rho_a * exp(1.0) + B = (CS%max_windspeed**2 / dP ) * CS%rho_a * exp(1.0) endif - A = (US%L_to_m*CS%rad_max_wind / 1000.)**B - f_local = G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant - if (BR_Bench) then - ! f reset to value used in generated wind for benchmark test - f_local = 5.5659e-05*US%T_to_s + if (CS%BR_Bench) then + A = (US%L_to_m*CS%rad_max_wind / 1000.)**B + else + A = (US%L_to_m*CS%rad_max_wind)**B + endif + ! f_local = f(x,y), but in the SCM it is constant + if (CS%BR_Bench) then ! (CS%SCM_mode) then + f_local = CS%f_column + else + f_local = G%CoriolisBu(is,js) endif - !/ BR - ! Calculate x position as a function of time. - xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) + + ! Calculate x position relative to hurricane center as a function of time. + xx = (t0 - time_type_to_real(day)*US%s_to_T) * CS%hurr_translation_spd * cos(transdir) rad = sqrt(xx**2 + CS%dy_from_center**2) - !/ BR + ! rkm - rad converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must ! be maintained. Causes winds far from storm center to be a ! couple of m/s higher than the correct Holland prof. - if (BR_Bench) then + if (CS%BR_Bench) then rkm = rad/1000. rB = (US%L_to_m*rkm)**B else @@ -556,43 +752,42 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C rkm = rad rB = (US%L_to_m*rad)**B endif - !/ BR - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. - ! Note that rho_a is set to 1.2 following generated wind for experiment - if (rad > 0.001*CS%rad_max_wind .AND. rad < 10.*CS%rad_max_wind) then - U10 = sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local - elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - rad=(CS%rad_max_wind)*10. - if (BR_Bench) then - rkm = rad/1000. + + ! Calculate U10 in the interior (inside of the hurricane edge radius), + ! while adjusting U10 to 0 outside of the ambient wind radius. + if (rad > 0.001*CS%rad_max_wind .AND. rad < CS%rad_edge*CS%rad_max_wind) then + U10 = sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local + elseif (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then + radius10 = CS%rad_max_wind*CS%rad_edge + if (CS%BR_Bench) then + rkm = radius10/1000. rB = (US%L_to_m*rkm)**B else - rkm = rad - rB = (US%L_to_m*rad)**B + rkm = radius10 + rB = (US%L_to_m*radius10)**B endif - U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & - * (12. - rad/CS%rad_max_wind)/2. + if (CS%edge_taper_bug) rad = radius10 + U10 = ( sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & + * (CS%rad_ambient - rad/CS%rad_max_wind)/(CS%rad_ambient - CS%rad_edge) else U10 = 0. endif Adir = atan2(CS%dy_from_center,xx) - !/ BR ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10., rad / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0 *(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31)*pie/180. + RSTR = min(CS%rad_edge, rad / CS%rad_max_wind) + A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 + A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) + P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%pi/180. ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - ALPH = ALPH* (12. - rad/CS%rad_max_wind)/2. - elseif (rad > 12.*CS%rad_max_wind) then + if (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then + ALPH = ALPH* (CS%rad_ambient - rad/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) + elseif (rad > CS%rad_ambient*CS%rad_max_wind) then ALPH = 0.0 endif - ALPH = ALPH * Deg2Rad - !/BR + ALPH = ALPH * CS%Deg2Rad + ! Prepare for wind calculation ! X_TS is component of translation speed added to wind vector ! due to background steering wind. @@ -604,55 +799,33 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq - !/BR ! Turn off surface current for stress calculation to be ! consistent with test case. Uocn = 0. ! sfc_state%u(I,j) Vocn = 0. ! 0.25*( (sfc_state%v(i,J) + sfc_state%v(i+1,J-1)) + & ! (sfc_state%v(i+1,J) + sfc_state%v(i,J-1)) ) - !/BR ! Wind vector calculated from location/direction (sin/cos flipped b/c ! cyclonic wind is 90 deg. phase shifted from position angle). - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS - dV = U10*cos(Adir-Alph) - Vocn + V_TS + dU = U10*sin(Adir - CS%pi - Alph) - Uocn + U_TS + dV = U10*cos(Adir - Alph) - Vocn + V_TS !/----------------------------------------------------| - !BR ! Add a simple drag coefficient as a function of U10 | !/----------------------------------------------------| du10 = sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif + Cd = simple_wind_scaled_Cd(u10, du10, CS) + forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU enddo ; enddo - !/BR + ! See notes above do J=js-1,Jeq ; do i=is,ie Uocn = 0. ! 0.25*( (sfc_state%u(I,j) + sfc_state%u(I-1,j+1)) + & ! (sfc_state%u(I-1,j) + sfc_state%u(I,j+1)) ) Vocn = 0. ! sfc_state%v(i,J) - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dU = U10*sin(Adir - CS%pi - Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS - du10=sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answer_date < 20190101) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif + du10 = sqrt(du**2+dv**2) + Cd = simple_wind_scaled_Cd(u10, du10, CS) forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo @@ -673,4 +846,27 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C end subroutine SCM_idealized_hurricane_wind_forcing +!> This function returns the air-sea drag coefficient using a simple function of the air-sea velocity difference. +function simple_wind_scaled_Cd(u10, du10, CS) result(Cd) + real, intent(in) :: U10 !< The 10 m wind speed [L T-1 ~> m s-1] + real, intent(in) :: du10 !< The magnitude of the difference between the 10 m wind + !! and the ocean flow [L T-1 ~> m s-1] + type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters + real :: Cd ! Air-sea drag coefficient [nondim] + + ! Note that these expressions are discontinuous at dU10 = 11 and 20 m s-1. + if (dU10 < CS%calm_speed) then + Cd = CS%Cd_calm + elseif (dU10 < CS%windy_speed) then + if (CS%answer_date < 20190101) then + Cd = (CS%Cd_intercept + CS%dCd_dU10 * U10 )*0.001 + else + Cd = (CS%Cd_intercept + CS%dCd_dU10 * dU10 )*0.001 + endif + else + Cd = CS%Cd_windy + endif + +end function simple_wind_scaled_Cd + end module idealized_hurricane From 9059671be5e4fa5e2fbe314609a0cc3f0592e164 Mon Sep 17 00:00:00 2001 From: Theresa Morrison <114184229+theresa-morrison@users.noreply.github.com> Date: Mon, 3 Jun 2024 09:33:36 -0400 Subject: [PATCH 004/128] Add rescaling parameter to kappa shear (#643) * Add rescaling paramter to KD Shear Add a parameted (beta) to rescale the distance to the nearest solid boundary that is used within calculation of kappa shear. While rescaling this value is unphysical, this adjustment can be thought of as not allowing shear instabilities to grow up to the full distance to the nearest boundary because of other turbulent processes which would disrupt their growth. * Rename parameter and swtich to multiplication Rename the parameter beta to lz_rescale to be more descriptive. To avoid two divisions in a single line, the inverse of lz_rescale is calculated and stored as I_lz_rescale_sqr. Where the calculation is done logic has been added to check that lz_rescale is greater than zero to avoid dividing by zero or making lz_rescale negative. * Add Comment where lz_rescale is used Based on Wei's suggestion, add a comment where lz_rescale is used and put the multiplication by I_lz_rescale to the next line. * Remove Trailing whitespace --------- Co-authored-by: Theresa Morrison Co-authored-by: Theresa Morrison Co-authored-by: Theresa Morrison Co-authored-by: Theresa Morrison --- .../vertical/MOM_kappa_shear.F90 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 8a1974d8ea..dac8508b4d 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -54,6 +54,10 @@ module MOM_kappa_shear real :: lambda2_N_S !< The square of the ratio of the coefficients of !! the buoyancy and shear scales in the diffusivity !! equation, 0 to eliminate the shear scale [nondim]. + real :: lz_rescale !< A coefficient to rescale the distance to the nearest + !! solid boundary. This adjustment is to account for + !! regions where 3 dimensional turbulence prevents the + !! growth of shear instabilies [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that @@ -746,6 +750,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la real :: wt_b ! The fraction of a layer thickness identified with the interface ! below a layer [nondim] real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. + real :: I_lz_rescale_sqr ! The inverse of a rescaling factor for L2_bdry (Lz) squared [nondim]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -764,6 +769,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 k0dt = dt*CS%kappa_0 + I_lz_rescale_sqr = 1.0; if (CS%lz_rescale > 0) I_lz_rescale_sqr = 1/(CS%lz_rescale*CS%lz_rescale) + tol_dksrc = CS%kappa_src_max_chg if (tol_dksrc == 10.0) then ! This is equivalent to the expression below, but avoids changes at roundoff for the default value. @@ -794,8 +801,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la do K=nzc,2,-1 dist_from_bot = dist_from_bot + dz_lay(k) h_from_bot = h_from_bot + hlay(k) + ! Find the inverse of the squared distances from the boundaries, I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) + ! reduce the distance by a factor of "lz_rescale" + I_L2_bdry(K) = I_lz_rescale_sqr*I_L2_bdry(K) enddo ! Determine the velocities and thicknesses after eliminating massless @@ -1918,6 +1928,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & units="nondim", default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "LZ_RESCALE", CS%lz_rescale, & + "A coefficient to rescale the distance to the nearest solid boundary. "//& + "This adjustment is to account for regions where 3 dimensional turbulence "//& + "prevents the growth of shear instabilies [nondim].", & + units="nondim", default=1.0) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & "The fractional error in kappa that is tolerated. "//& "Iteration stops when changes between subsequent "//& From f0badc6b6586d9f67bb38e4d10087856a222076e Mon Sep 17 00:00:00 2001 From: yichengt900 Date: Tue, 28 May 2024 21:36:05 -0400 Subject: [PATCH 005/128] Prestore axes_data in set_up_ALE_sponge_field fix style errors Modify axes_data to make it allocatable fix style --- src/framework/MOM_horizontal_regridding.F90 | 15 +++++++++++++-- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 14 ++++++++------ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index ce739cba55..1d5eab106d 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -627,7 +627,8 @@ end subroutine horiz_interp_and_extrap_tracer_record subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & z_in, z_edges_in, missing_value, scale, & homogenize, spongeOngrid, m_to_Z, & - answers_2018, tr_iter_tol, answer_date) + answers_2018, tr_iter_tol, answer_date, & + axes) type(external_field), intent(in) :: field !< Handle for the time interpolated field type(time_type), intent(in) :: Time !< A FMS time type @@ -663,6 +664,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & !! Dates before 20190101 give the same answers !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. + type(axis_info), allocatable, dimension(:), optional, intent(inout) :: axes !< Axis types for the input data ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the @@ -742,7 +744,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call cpu_clock_begin(id_clock_read) - call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + if (present(axes) .and. allocated(axes)) then + call get_external_field_info(field, size=fld_sz, missing=missing_val_in) + axes_data = axes + else + call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + if (present(axes)) then + allocate(axes(4)) + axes = axes_data + endif + endif missing_value = scale*missing_val_in verbosity = MOM_get_verbosity() diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 0f4b50237e..f1739485d6 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -23,6 +23,7 @@ module MOM_ALE_sponge use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init use MOM_interpolate, only : external_field +use MOM_io, only : axis_info use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type @@ -86,6 +87,7 @@ module MOM_ALE_sponge character(len=:), allocatable :: name !< The name of the input field character(len=:), allocatable :: long_name !< The long name of the input field character(len=:), allocatable :: unit !< The unit of the input field + type(axis_info), allocatable :: axes_data(:) !< Axis types for the input field end type p2d !> ALE sponge control structure @@ -770,7 +772,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, CS%Ref_val(CS%fldno)%long_name = long_name CS%Ref_val(CS%fldno)%unit = unit fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz) + call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz, axes=CS%Ref_val(CS%fldno)%axes_data) nz_data = fld_sz(3) CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) @@ -868,7 +870,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_u%field, size=fld_sz) + call get_external_field_info(CS%Ref_val_u%field, size=fld_sz, axes=CS%Ref_val_u%axes_data) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) CS%Ref_val_u%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_u%scale = scale @@ -879,7 +881,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_v%field, size=fld_sz) + call get_external_field_info(CS%Ref_val_v%field, size=fld_sz, axes=CS%Ref_val_v%axes_data) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) CS%Ref_val_v%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_v%scale = scale @@ -963,7 +965,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val(m)%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val(m)%axes_data) allocate( dz_src(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col @@ -1053,7 +1055,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val_u%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_u%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_u%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc-1, G%jsc:G%jec, :) = 0. @@ -1101,7 +1103,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val_v%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_v%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answer_date=CS%hor_regrid_answer_date) + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_v%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc:G%iec, G%jsc-1, :) = 0. mask_z(G%isc:G%iec, G%jec+1, :) = 0. From 08a6106a102998d0a4aa52e0cc1f5297d01f09a5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 May 2024 18:08:21 -0400 Subject: [PATCH 006/128] +Add ROBUST_STOKES_PGF and LA_MISALIGNMENT_BUG Added the new runtime parameters ROBUST_STOKES_PGF and LA_MISALIGNMENT_BUG to allow for the selection of Stokes pressure gradient force calculations that work properly in the limit of vanishingly thin layers and to correct a sign error in the calculations of the misalignment between the waves and shears in the Langmuir number calculations when LA_MISALIGNMENT is true. By default, all answers are bitwise identical, but as these options are not yet widely used it might make sense to move aggressively to obsolete the previous code once more extensive testing has take place. There will be new entries in the MOM_parameter_doc files for some cases, but there are not yet any such cases in the MOM-examples regression suite. --- src/user/MOM_wave_interface.F90 | 191 ++++++++++++++++++++++++-------- 1 file changed, 143 insertions(+), 48 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 656ff5b569..bcd66843ac 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -59,6 +59,9 @@ module MOM_wave_interface logical, public :: Stokes_VF = .false. !< True if Stokes vortex force is used logical, public :: Passive_Stokes_VF = .false. !< Computes Stokes VF, but doesn't affect dynamics logical, public :: Stokes_PGF = .false. !< True if Stokes shear pressure Gradient force is used + logical, public :: robust_Stokes_PGF = .false. !< If true, use expressions to calculate the + !! Stokes-induced pressure gradient anomalies that are + !! more accurate in the limit of thin layers. logical, public :: Passive_Stokes_PGF = .false. !< Keeps Stokes_PGF on, but doesn't affect dynamics logical, public :: Stokes_DDT = .false. !< Developmental: !! True if Stokes d/dt is used @@ -164,6 +167,8 @@ module MOM_wave_interface real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + logical :: LA_misalign_bug = .false. !< Flag to use code with a sign error when calculating the + !! misalignment between the shear and waves in the Langmuir number calculation. real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] @@ -377,22 +382,27 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) call get_param(param_file, mdl, "STOKES_VF", CS%Stokes_VF, & "Flag to use Stokes vortex force", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_VF", CS%Passive_Stokes_VF, & "Flag to make Stokes vortex force diagnostic only.", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "STOKES_PGF", CS%Stokes_PGF, & "Flag to use Stokes-induced pressure gradient anomaly", & - Default=.false.) + default=.false.) + call get_param(param_file, mdl, "ROBUST_STOKES_PGF", CS%robust_Stokes_PGF, & + "If true, use expressions to calculate the Stokes-induced pressure gradient "//& + "anomalies that are more accurate in the limit of thin layers.", & + default=.false., do_not_log=.not.CS%Stokes_PGF) + !### Change the default for ROBUST_STOKES_PGF to True. call get_param(param_file, mdl, "PASSIVE_STOKES_PGF", CS%Passive_Stokes_PGF, & "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "STOKES_DDT", CS%Stokes_DDT, & "Flag to use Stokes d/dt", & - Default=.false.) + default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_DDT", CS%Passive_Stokes_DDT, & "Flag to make Stokes d/dt diagnostic only", & - Default=.false.) + default=.false.) ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & @@ -526,6 +536,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & "Flag (logical) if using misalignment between shear and waves in LA", & default=.false.) + call get_param(param_file, mdl, "LA_MISALIGNMENT_BUG", CS%LA_misalign_bug, & + "If true, use a code with a sign error when calculating the misalignment between "//& + "the shear and waves when LA_MISALIGNMENT is true.", & + default=CS%LA_Misalignment, do_not_log=.not.CS%LA_Misalignment) + !### Change the default for LA_MISALIGNMENT_BUG to .false. call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& @@ -1030,6 +1045,18 @@ real function one_minus_exp_x(x) endif end function one_minus_exp_x +!> Return the value of (1 - exp(-x)), using an accurate expression for small values of x. +real function one_minus_exp(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] + if (abs(x) <= 2.0e-5) then + ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. + one_minus_exp = x * (1.0 - x * (0.5 - C1_6*x)) + else + one_minus_exp = 1.0 - exp(-x) + endif +end function one_minus_exp + !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) @@ -1199,12 +1226,18 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & Top = Bottom MidPoint = Bottom + 0.5*dz(k) Bottom = Bottom + dz(k) - !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. - ! To correct this bug, this line should be changed to: - ! if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then - if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then - ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) - ContinueLoop = .false. + + if (Waves%LA_Misalign_bug) then + ! Given the sign convention that Dpt_LASL is negative, the next line has a bug. + if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif + else ! This version avoids the bug in the version above. + if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif endif enddo endif @@ -1706,7 +1739,9 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) real :: P_Stokes_l0, P_Stokes_r0 ! Stokes-induced pressure anomaly at interface ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: dP_Stokes_l_dz, dP_Stokes_r_dz ! Contribution of layer to integrated Stokes pressure anomaly for summation - ! (left/right of point) [L3 T-2 ~> m3 s-2] + ! (left/right of point) [Z L2 T-2 ~> m3 s-2] + real :: dP_lay_Stokes_l, dP_lay_Stokes_r ! Contribution of layer to integrated Stokes pressure anomaly for summation + ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: dP_Stokes_l, dP_Stokes_r ! Net increment of Stokes pressure anomaly across layer for summation ! (left/right of point) [L2 T-2 ~> m2 s-2] real :: uE_l, uE_r, vE_l, vE_r ! Eulerian velocity components (left/right of point) [L T-1 ~> m s-1] @@ -1714,6 +1749,7 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) real :: zi_l(SZK_(G)+1), zi_r(SZK_(G)+1) ! The height of the edges of the cells (left/right of point) [Z ~> m]. real :: idz_l(SZK_(G)), idz_r(SZK_(G)) ! The inverse thickness of the cells (left/right of point) [Z-1 ~> m-1] real :: h_l, h_r ! The thickness of the cell (left/right of point) [Z ~> m]. + real :: exp_top ! The decay of the surface stokes drift to the interface atop a layer [nondim] real :: dexp2kzL, dexp4kzL, dexp2kzR, dexp4kzR ! Analytical evaluation of multi-exponential decay ! contribution to Stokes pressure anomalies [nondim]. real :: TwoK, FourK ! Wavenumbers multiplied by a factor [Z-1 ~> m-1] @@ -1762,9 +1798,11 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) h_r = dz(i+1,j,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - !### If the code were properly refactored, the following hard-coded constants would be unnecessary. - Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) - Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + endif enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1798,31 +1836,59 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) ! Wavenumber terms that are useful to simplify the pressure calculations TwoK = 2.*CS%WaveNum_Cen(l) FourK = 2.*TwoK - iTwoK = 1./TwoK - iFourK = 1./(FourK) - dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) - dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) - dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) - dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif ! Compute Pressure at interface and integrated over layer on left/right bounding points. ! These are summed over wavenumber bands. if (G%mask2dT(i,j)>0.5) then - dP_Stokes_l_dz = dP_Stokes_l_dz + & - ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) - dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif endif if (G%mask2dT(i+1,j)>0.5) then - dP_Stokes_r_dz = dP_Stokes_r_dz + & - ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) - dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i+1,j,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i+1,j,k)) ) + endif endif enddo ! Summing PF over bands ! > Increment the Layer averaged pressure - P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) - P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + ! > Increment the Interface pressure P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r @@ -1856,9 +1922,11 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) h_r = dz(i,j+1,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - !### If the code were properly refactored, the following hard-coded constants would be unnecessary. - Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) - Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + endif enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1892,31 +1960,59 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) ! Wavenumber terms that are useful to simplify the pressure calculations TwoK = 2.*CS%WaveNum_Cen(l) FourK = 2.*TwoK - iTwoK = 1./TwoK - iFourK = 1./(FourK) - dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) - dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) - dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) - dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif ! Compute Pressure at interface and integrated over layer on left/right bounding points. ! These are summed over wavenumber bands. if (G%mask2dT(i,j)>0.5) then - dP_Stokes_l_dz = dP_Stokes_l_dz + & - ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) - dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif endif if (G%mask2dT(i,j+1)>0.5) then - dP_Stokes_r_dz = dP_Stokes_r_dz + & - ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) - dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j+1,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j+1,k)) ) + endif endif enddo ! Summing PF over bands ! > Increment the Layer averaged pressure - P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) - P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + ! > Increment the Interface pressure P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r @@ -1939,7 +2035,6 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) end subroutine Stokes_PGF - !> Computes wind speed from ustar_air based on COARE 3.5 Cd relationship !! Probably doesn't belong in this module, but it is used here to estimate !! wind speed for wind-wave relationships. Should be a fine way to estimate From e58b95f3d6926827c6ffba6c353df67374f8e503 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Thu, 18 Jan 2024 13:01:34 -0500 Subject: [PATCH 007/128] Ice-shelf dynamics updates -Account for re-entry boundary conditions and non-symmetric grids -Optimized SSA CG scheme to eliminate unneeded loops and pass_var calls -Added a missing pass_var call that should fix a reproducibility issue on different PE layouts -Automatically adjust ice-shelf velocity data when it is read in from file so that it agrees with assigned BCs -Changed some ice-shelf mass units that were affecting partially-fully cells at the ice front, so that they are always mass per ice-shelf area (not per grid area) --- src/ice_shelf/MOM_ice_shelf.F90 | 10 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 369 ++++++++++------------- 2 files changed, 157 insertions(+), 222 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3f4c260eb4..05c70a0ea1 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -821,7 +821,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) endif if (CS%shelf_mass_is_dynamic) & - call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & time_step=real_to_time(US%T_to_s*time_step) ) if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) @@ -1004,7 +1004,7 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo @@ -2270,7 +2270,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice endif enddo ; enddo @@ -2498,8 +2498,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in enddo - call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, time_step=time_interval) - + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & + time_step=time_interval) do j=js,je ; do i=is,ie ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step enddo; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 27cb4721bf..837789716b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -137,6 +137,8 @@ module MOM_ice_shelf_dynamics real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness + logical :: reentrant_x !< If true, the domain is zonally reentrant + logical :: reentrant_y !< If true, the domain is meridionally reentrant logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction !! updates occur first in directionally split parts of the calculation. integer :: first_direction_IS !< An integer that indicates which direction is @@ -536,6 +538,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & "If true, advect ice shelf and evolve thickness", & default=.true.) + call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & + " If true, the domain is zonally reentrant.", & + default=.false.) + call get_param(param_file, mdl, "REENTRANT_Y", CS%reentrant_y, & + " If true, the domain is meridionally reentrant.", & + default=.false.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points,"//& "if OBS read from a file,"//& @@ -642,9 +650,22 @@ 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 - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly. + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_var(CS%ice_visc, G%domain) + + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + + ! This is unfortunately necessary (?); if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. if (.not. G%symmetric) then @@ -679,20 +700,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif enddo ; enddo endif - - call pass_var(CS%OD_av,G%domain, complete=.false.) - call pass_var(CS%ground_frac, G%domain, complete=.false.) - call pass_var(CS%basal_traction, G%domain, complete=.false.) - call pass_var(CS%AGlen_visc, G%domain, complete=.false.) - call pass_var(CS%bed_elev, G%domain, complete=.false.) - call pass_var(CS%C_basal_friction, G%domain, complete=.false.) - call pass_var(CS%h_bdry_val, G%domain, complete=.true.) - call pass_var(CS%ice_visc, G%domain) - - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif if (active_shelf_dynamics) then @@ -752,7 +760,21 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%ground_frac, G%domain, complete=.false.) call pass_var(CS%bed_elev, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 3) then + CS%u_shelf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + CS%u_shelf(I,J) = 0 + endif + if (CS%vmask(I,J) == 3) then + CS%v_shelf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + CS%v_shelf(I,J) = 0 + endif + enddo ; enddo 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) @@ -1011,13 +1033,15 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, G) end subroutine IS_dynamics_post_data !> Writes the total ice shelf kinetic energy and mass to an ascii file -subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) +subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: mass !< The mass per unit area of the ice shelf !! or sheet [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: area !< The ice shelf or ice sheet area [L2 ~> m2] type(time_type), intent(in) :: day !< The current model time. type(time_type), optional, intent(in) :: time_step !< The current time step ! Local variables @@ -1076,7 +1100,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) tmp1(:,:)=0.0 KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) do j=js,je ; do i=is,ie - tmp1(i,j) = (KE_scale_factor * 0.03125) * (G%areaT(i,j) * mass(i,j)) * & + tmp1(i,j) = (KE_scale_factor * 0.03125) * (mass(i,j) * area(i,j)) * & (((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2 + & ((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2) enddo; enddo @@ -1087,7 +1111,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) tmp1(:,:)=0.0 mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 do j=js,je ; do i=is,ie - tmp1(i,j) = mass_scale_factor * (mass(i,j) * G%areaT(i,j)) + tmp1(i,j) = mass_scale_factor * (mass(i,j) * area(i,j)) enddo; enddo mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -1241,7 +1265,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) endif do j=jsc,jec; do i=isc,iec - ISS%mass_shelf(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice enddo; enddo call pass_var(ISS%mass_shelf, G%domain, complete=.false.) @@ -1281,14 +1305,18 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message - integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat + integer :: conv_flag, i, j, k,l, iter, nodefloat + integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed + integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 @@ -1336,6 +1364,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call pass_var(CS%float_cond, G%Domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) endif @@ -1379,20 +1408,25 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(err_init) elseif (CS%nonlin_solve_err_mode == 3) then Normvec=0.0 + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) + + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) - enddo; enddo + enddo ; enddo Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) Norm = sqrt(Norm) endif @@ -1483,7 +1517,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 3) then PrevNorm=Norm; Norm=0.0; Normvec=0.0 - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) enddo; enddo @@ -1545,7 +1579,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! one linear solve (nonlinear iteration) of the solution for velocity ! in this subroutine: -! boundary contributions are added to taud to get the RHS +! RHS = taud ! diagonal of matrix is found (for Jacobi precondition) ! CG iteration is carried out for max. iterations or until convergence @@ -1560,9 +1594,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] - sum_vec, sum_vec_2 !, & + sum_vec, sum_vec_2, sum_vec_3 !, & !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] - real :: beta_k, dot_p1, resid0, cg_halo + real :: beta_k, dot_p1, resid0tol2, cg_halo, max_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] @@ -1571,10 +1605,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. - integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1587,18 +1622,20 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) - RHSu(:,:) = taudx(:,:) - RHSv(:,:) = taudy(:,:) + RHSu(:,:) = taudx(:,:) ; RHSv(:,:) = taudy(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) @@ -1613,31 +1650,32 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) - Ru(:,:) = (RHSu(:,:) - Au(:,:)) - Rv(:,:) = (RHSv(:,:) - Av(:,:)) + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) resid_scale = (US%L_to_m**2*US%s_to_T)*(US%RZ_to_kg_m2*US%L_T_to_m_s**2) resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - - resid0 = sqrt(dot_p1) + !resid0 = sqrt(reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum )) + resid0tol2 = CS%cg_tolerance**2 * reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) - enddo - enddo + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) + enddo ; enddo Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - cg_halo = 3 + if (G%symmetric) then + max_cg_halo=min(nx_halo,ny_halo) + else + max_cg_halo=min(nx_halo,ny_halo)-1 + endif + cg_halo = max_cg_halo conv_flag = 0 !!!!!!!!!!!!!!!!!! @@ -1650,13 +1688,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do iter = 1,CS%cg_max_iterations - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past + ! we can never assume that any arrays are legit more than 3 vertices past ! the computational domain - this is their state in the initial iteration - - is = iscq - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo Au(:,:) = 0 ; Av(:,:) = 0 @@ -1670,98 +1706,68 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) + Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) + Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) endif enddo ; enddo alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) - - do j=jsd,jed ; do i=isd,ied - if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) - if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) - enddo ; enddo - - do j=jsd,jed ; do i=isd,ied + do J=js,je-1 ; do I=is,ie-1 if (CS%umask(I,J) == 1) then - Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) + u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + if (DIAGu(I,J)/=0) Zu(I,J) = Ru(I,J) / DIAGu(I,J) endif if (CS%vmask(I,J) == 1) then - Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) + v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) + if (DIAGv(I,J)/=0) Zv(I,J) = Rv(I,J) / DIAGv(I,J) endif - enddo ; enddo - -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) - - do j=jsd,jed - do i=isd,ied - if (CS%umask(I,J) == 1) Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) - if (CS%vmask(I,J) == 1) Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) - enddo - enddo + enddo; enddo - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) then - Zu(I,J) = Ru(I,J) / DIAGu(I,J) - endif - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) then - Zv(I,J) = Rv(I,J) / DIAGv(I,J) - endif - enddo - enddo ! R,u,v,Z valid region moves in by 1 ! beta_k = (Z \dot R) / (Zold \dot Rold) - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 ; sum_vec_3(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq + do J=jscq_sv,jecq ; do i=iscq_sv,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) - sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) + sum_vec_3(I,J) = resid2_scale * Ru(I,J)**2 endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) + sum_vec_3(I,J) = sum_vec_3(I,J) + resid2_scale * Rv(I,J)**2 endif enddo ; enddo beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied + do J=js,je-1 ; do I=is,ie-1 if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) - enddo - enddo - - ! D valid region moves in by 1 - - sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 - if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - dot_p1 = sqrt(dot_p1) + ! D valid region moves in by 1 + dot_p1 = reproducing_sum( sum_vec_3, Is_sum, Ie_sum, Js_sum, Je_sum ) - if (dot_p1 <= (CS%cg_tolerance * resid0)) then + !if sqrt(dot_p1) <= (CS%cg_tolerance * resid0) + if (dot_p1 <= resid0tol2) then iters = iter conv_flag = 1 exit @@ -1774,13 +1780,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) - cg_halo = 3 + cg_halo = max_cg_halo endif enddo ! end of CG loop - do j=jsdq,jedq - do i=isdq,iedq + do J=Jsdq,Jedq ; do I=Isdq,Iedq if (CS%umask(I,J) == 3) then u_shlf(I,J) = CS%u_bdry_val(I,J) elseif (CS%umask(I,J) == 0) then @@ -1792,8 +1797,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H elseif (CS%vmask(I,J) == 0) then v_shlf(I,J) = 0 endif - enddo - enddo + enddo ; enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) if (conv_flag == 0) then @@ -1830,7 +1834,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after ! 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 ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -2056,16 +2059,19 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) iter_count = iter_count + 1 ! if iter_count >= 3 then some halo updates need to be done... + if (iter_count==3) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, shelf_advance_front iter >=3.") + endif do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal) .AND. & - ((j+j_off) >= 1)) then + if (CS%reentrant_y .OR. (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1))) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal) .AND. & - ((i+i_off) >= 1)) then + if (CS%reentrant_x .OR. (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1))) then ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference_ew = 0.0 @@ -2316,13 +2322,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx - if ((i+i_off) == gisc) then ! at west computational bdry + if (((i+i_off) == gisc) .and. (.not. CS%reentrant_x)) then ! at west computational bdry if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif - elseif ((i+i_off) == giec) then ! at east computational bdry + elseif (((i+i_off) == giec) .and. (.not. CS%reentrant_x)) then ! at east computational bdry if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then sx = (S(i,j)-S(i-1,j))/dxh else @@ -2353,13 +2359,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) cnt = 0 ! calculate sy, similarly - if ((j+j_off) == gjsc) then ! at south computational bdry + if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif - elseif ((j+j_off) == gjec) then ! at north computational bdry + elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then sy = (S(i,j)-S(i,j-1))/dyh else @@ -2397,7 +2403,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * ISS%h_shelf(i,j)**2)) endif if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & - ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off /= gisc))) then + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (CS%reentrant_x .OR. (i+i_off /= gisc)))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -2412,21 +2418,21 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & - ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off /= giec))) then + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (CS%reentrant_x .OR. (i+i_off /= giec)))) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & - ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off /= gjsc))) then + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjsc)))) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & - ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off /= gjec))) then + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjec)))) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2441,76 +2447,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo; enddo end subroutine calc_shelf_driving_stress -! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 -subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) - type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(time_type), intent(in) :: Time !< The current model time - 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, intent(in) :: input_flux !< The integrated inward ice thickness flux per - !! unit face length [Z L T-1 ~> m2 s-1] - real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. - logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! 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 :: isc, jsc, iec, jec - integer :: i_off, j_off - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - - if (hmask(i,j) == 3) then - CS%h_bdry_val(i,j) = input_thick - endif - - if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then - if ((i <= iec).and.(i >= isc)) then - if (CS%u_face_mask(I-1,j) == 3) then - CS%u_bdry_val(I-1,J-1) = (1 - ((G%geoLatBu(I-1,J-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - CS%u_bdry_val(I-1,J) = (1 - ((G%geoLatBu(I-1,J) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) - endif - if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values - - subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) @@ -3029,7 +2965,7 @@ 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, isc, jsc, iec, jec, is, js, i_off, j_off + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: Visc_coef, n_g real :: ux, uy, vx, vy real :: eps_min ! Velocity shears [T-1 ~> s-1] @@ -3042,7 +2978,6 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 - i_off = G%idg_offset ; j_off = G%jdg_offset if (trim(CS%ice_viscosity_compute) == "MODEL") then if (CS%visc_qps==1) then From 7ccea2a494df87662a311e5db672e591ec579b85 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Apr 2024 17:06:16 -0400 Subject: [PATCH 008/128] Add units to the descriptions of 79 variables This commit improves the documentation of the remaining real variables with previously undocumented units in the framework directory, with some other similar unit documentation improvements in other files. Units were added to comments describing about 79 real variables in 4 framework modules, atmos_ocean_fluxes.F90 for 2 drivers, MOM_oda_incupd.F90, MOM_oda_driver.F90 and MOM_variables.F90. The variable nhours_incupd in initialize_oda_incupd was renamed to incupd_timescale and the factor of 3600.0 that converts ODA_INCUPD_NHOURS from hours into seconds was moved from where this variable is used into the scale argument where it is set to help document the meaning and units of this variable as simply and clearly as possible. The unused variable smb was removed from Shelf_main in ice_shelf_driver.F90. The internal variable tmp in RGC_initialize_sponges was renamed rho to reflect its contents, and its contents and units are now described in a comment. Although the units have been added to the description in MEKE_vec as though it is being used in a dimensionally consistent way, I suspect that this might actually be in MKS units, in which case a unit conversion factor might be needed, and a comment has been added to note this. However, the machine learning code that is used to set this array comes from an external package that is not being used yet at GFDL, so it is not clear what code should be examined to address this question. A comment was added in set_up_global_tgrid noting a unit rescaling factor that appears to be missing from a dimensional constant. All answers are bitwise identical, and for the most part only comments are changed, although two internal variables were renamed. --- .../ice_solo_driver/atmos_ocean_fluxes.F90 | 7 ++- .../ice_solo_driver/ice_shelf_driver.F90 | 1 - .../solo_driver/atmos_ocean_fluxes.F90 | 7 ++- src/core/MOM_variables.F90 | 4 +- src/framework/MOM_coms.F90 | 50 ++++++++++--------- src/framework/MOM_coupler_types.F90 | 46 ++++++++++++----- src/framework/MOM_intrinsic_functions.F90 | 8 +-- src/framework/MOM_random.F90 | 12 ++--- src/ocean_data_assim/MOM_oda_driver.F90 | 10 +++- src/ocean_data_assim/MOM_oda_incupd.F90 | 42 +++++++++------- src/parameterizations/lateral/MOM_MEKE.F90 | 10 ++-- src/user/RGC_initialization.F90 | 6 +-- 12 files changed, 124 insertions(+), 79 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..fb9fbe3e22 100644 --- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -20,9 +20,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 787fa7e7d1..753269116a 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -143,7 +143,6 @@ program Shelf_main integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. - real :: smb !A constant surface mass balance that can be specified in the param_file character(len=9) :: month character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 diff --git a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..fb9fbe3e22 100644 --- a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 @@ -20,9 +20,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 2510ff95a5..d5d20f0400 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -31,11 +31,11 @@ module MOM_variables !> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] end type p3d !> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] end type p2d !> Pointers to various fields which may be used describe the surface state of MOM, and which diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 38ad55fd96..e7c38d988d 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -26,8 +26,8 @@ module MOM_coms ! This module provides interfaces to the non-domain-oriented communication subroutines. integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. -real, parameter :: r_prec=2.0**46 !< A real version of prec. -real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec. +real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. +real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. integer, parameter :: max_count_prec=2**(63-46)-1 !< The number of values that can be added together !! with the current value of prec before there will @@ -37,12 +37,12 @@ module MOM_coms !< a real number. real, parameter, dimension(ni) :: & pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) - !< An array of the real precision of each of the integers + !< An array of the real precision of each of the integers in arbitrary units [a] real, parameter, dimension(ni) :: & I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) - !< An array of the inverse of the real precision of each of the integers + !< An array of the inverse of the real precision of each of the integers in arbitrary units [a-1] real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) - !< The largest float with an EFP representation. + !< The largest float with an EFP representation in arbitrary units [a]. !! NOTE: Only the first bin can exceed precision, !! but is bounded by the largest signed integer. @@ -91,7 +91,7 @@ module MOM_coms !! using EFP_to_real. This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, !! doi:10.1016/j.parco.2014.04.007. function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) result(EFP_sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -117,8 +117,8 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, integer(kind=8), dimension(ni) :: ints_sum integer(kind=8) :: ival, prec_error - real :: rs - real :: max_mag_term + real :: rs ! The remaining value to add, in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] logical :: over_check, do_sum_across_PEs character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn @@ -218,7 +218,7 @@ end function reproducing_EFP_sum_2d !! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & overflow_check, err, only_on_PE) result(sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -239,7 +239,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum !! across processors, only reporting the local sum - real :: sum !< Result + real :: sum !< The sum of the values in array in arbitrary units [a] ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -247,7 +247,7 @@ 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) + real :: rsum(1) ! The running sum, in arbitrary units [a] logical :: repro, do_sum_across_PEs character(len=256) :: mesg type(EFP_type) :: EFP_val ! An extended fixed point version of the sum @@ -323,7 +323,7 @@ end function reproducing_sum_2d !! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE) & result(sum) - real, dimension(:,:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:,:), intent(in) :: array !< The array to be summed in arbitrary units [a] integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -332,7 +332,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su !! that the array indices starts at 1 integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting !! that the array indices starts at 1 - real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer in abitrary units [a] type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format type(EFP_type), dimension(:), & optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format @@ -341,13 +341,14 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum !! across processors, only reporting the local sum - real :: sum !< Result + real :: sum !< The sum of the values in array in arbitrary units [a] ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - real :: val, max_mag_term + real :: val ! The real number that is extracted in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] integer(kind=8), dimension(ni) :: ints_sum integer(kind=8), dimension(ni,size(array,3)) :: ints_sums integer(kind=8) :: prec_error @@ -506,7 +507,7 @@ end function reproducing_sum_3d !> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r !< The real number being converted + real, intent(in) :: r !< The real number being converted in arbitrary units [a] integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time @@ -517,7 +518,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) ! This subroutine converts a real number to an equivalent representation ! using several long integers. - real :: rs + real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg integer(kind=8) :: ival, prec_err integer :: sgn, i @@ -549,7 +550,7 @@ end function real_to_ints !! representation into a real number function ints_to_real(ints) result(r) integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers - real :: r + real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. integer :: i @@ -596,13 +597,14 @@ end subroutine increment_ints !! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - real, intent(in) :: r !< The real number being added. - real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. + real, intent(in) :: r !< The real number being added in arbitrary units [a] + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's + !! in arbitrary units [a] ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. ! The entire operation is embedded in a single call for greater speed. - real :: rs + real :: rs ! The remaining value to add, in arbitrary units [a] integer(kind=8) :: ival integer :: sgn, i @@ -740,7 +742,7 @@ end subroutine EFP_assign !> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted - real :: EFP_to_real + real :: EFP_to_real !< The real version of the number in abitrary units [a] call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) @@ -752,7 +754,7 @@ function EFP_real_diff(EFP1, EFP2) type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being !! subtracted from the first extended fixed point number - real :: EFP_real_diff !< The real result + real :: EFP_real_diff !< The real result in arbitrary units [a] type(EFP_type) :: EFP_diff @@ -763,7 +765,7 @@ end function EFP_real_diff !> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val !< The real number being converted + real, intent(in) :: val !< The real number being converted in arbitrary units [a] logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index f87b409694..1baef24f76 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -246,11 +246,15 @@ end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) - type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_2d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) @@ -260,11 +264,15 @@ end subroutine CT_increment_data_2d !> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) - type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_3d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types !! of fluxes to exclude from this increment. character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types @@ -281,7 +289,7 @@ end subroutine CT_increment_data_3d subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to - !! increment the 2d-data. There is no renormalization, + !! increment the 2d-data [nondim]. There is no renormalization, !! so if the weights do not sum to 1 in the 3rd dimension !! there may be adverse consequences! type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented @@ -294,8 +302,11 @@ end subroutine CT_increment_data_2d_3d !> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_2d(var, scale) - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -304,8 +315,11 @@ end subroutine CT_rescale_data_2d !> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_3d(var, scale) - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -351,12 +365,15 @@ end subroutine coupler_type_data_override subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & halo_size, idim, jdim, field_index) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + !! The internal data has arbitrary units [B]. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! extracted, in arbitrary units [A B-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -382,16 +399,19 @@ end subroutine extract_coupler_type_data !! MOM-specific interface. subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & halo_size, idim, jdim, field_index) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + !! The internal data has arbitrary units [B]. logical, optional, intent(in) :: solubility !< If true and field index is missing, set !! the solubility field. Otherwise set the !! surface concentration (the default). - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! set, in arbitrary units [B A-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index ae0a68df5f..3fd9ace1ad 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -117,9 +117,9 @@ end function cuberoot !> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. pure subroutine rescale_cbrt(a, x, e_r, s_a) real, intent(in) :: a - !< The real parameter to be rescaled for cube root + !< The real parameter to be rescaled for cube root in abitrary units cubed [A3] real, intent(out) :: x - !< The rescaled value of a + !< The rescaled value of a in the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] integer(kind=int64), intent(out) :: e_r !< Cube root of the exponent of the rescaling of `a` integer(kind=int64), intent(out) :: s_a @@ -162,13 +162,13 @@ end subroutine rescale_cbrt !> Undo the rescaling of a real number back to its original base. pure function descale(x, e_a, s_a) result(a) real, intent(in) :: x - !< The rescaled value which is to be restored. + !< The rescaled value which is to be restored in ambiguous units [B] integer(kind=int64), intent(in) :: e_a !< Exponent of the unscaled value integer(kind=int64), intent(in) :: s_a !< Sign bit of the unscaled value real :: a - !< Restored value with the corrected exponent and sign + !< Restored value with the corrected exponent and sign in abitrary units [A] integer(kind=int64) :: xb ! Bit-packed real number into integer form diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index f5e996d3e4..6fcc6903c9 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -99,7 +99,7 @@ end function random_norm subroutine random_2d_01(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j @@ -116,7 +116,7 @@ end subroutine random_2d_01 subroutine random_2d_norm(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j,n @@ -318,14 +318,14 @@ logical function random_unit_tests(verbose) ! Local variables type(PRNG) :: test_rng ! Generator type(time_type) :: Time ! Model time - real :: r1, r2, r3 ! Some random numbers and re-used work variables - real :: mean, var, ar1, std ! Some statistics + real :: r1, r2, r3 ! Some random numbers and re-used work variables [nondim] + real :: mean, var, ar1, std ! Some statistics [nondim] integer :: stdunit ! For messages integer, parameter :: n_samples = 800 integer :: i, j, ni, nj ! Fake being on a decomposed domain type(hor_index_type), pointer :: HI => null() !< Not the real HI - real, dimension(:,:), allocatable :: r2d ! Random numbers + real, dimension(:,:), allocatable :: r2d ! Random numbers [nondim] ! Fake a decomposed domain ni = 6 @@ -547,7 +547,7 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) logical, intent(in) :: verbose !< Verbosity logical, intent(in) :: good !< True if pass, false otherwise character(len=*), intent(in) :: label !< Label for messages - real, intent(in) :: rvalue !< Result of calculation + real, intent(in) :: rvalue !< Result of calculation [nondim] integer, intent(in) :: ivalue !< Result of calculation optional :: rvalue, ivalue diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 6e24b9faee..8453ceb497 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -119,7 +119,7 @@ module MOM_oda_driver_mod logical :: use_basin_mask !< If true, use a basin file to delineate weakly coupled ocean basins logical :: do_bias_adjustment !< If true, use spatio-temporally varying climatological tendency !! adjustment for Temperature and Salinity - real :: bias_adjustment_multiplier !< A scaling for the bias adjustment + real :: bias_adjustment_multiplier !< A scaling for the bias adjustment [nondim] integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM integer :: ensemble_size !< Size of the ensemble integer :: ensemble_id = 0 !< id of the current ensemble member @@ -734,13 +734,17 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) end subroutine apply_oda_tracer_increments +!> Set up the grid of thicknesses at tracer points throughout the global domain subroutine set_up_global_tgrid(T_grid, CS, G) type(grid_type), pointer :: T_grid !< global tracer grid type(ODA_CS), pointer, intent(in) :: CS !< A pointer to DA control structure. type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model ! local variables - real, dimension(:,:), allocatable :: global2D, global2D_old + real, dimension(:,:), allocatable :: & + global2D, & ! A layer thickness in the entire global domain [H ~> m or kg m-2] + global2D_old ! The thickness of the layer above the one in global2D in the entire + ! global domain [H ~> m or kg m-2] integer :: i, j, k ! get global grid information from ocean_model @@ -769,6 +773,8 @@ subroutine set_up_global_tgrid(T_grid, CS, G) do k = 1, CS%nk call global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) do i=1,CS%ni ; do j=1,CS%nj + ! ###Does the next line need to be revised? Perhaps it should be + ! if ( global2D(i,j) > 1.0*GV%H_to_m ) then if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 endif diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index be57bbe748..d54d34506e 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -52,9 +52,11 @@ module MOM_oda_incupd type :: p3d integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. - real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask. - real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. + real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask (perhaps unused) [nondim] + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data, in units that depend + !! on the field it refers to [various]. + real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid (perhaps unused) + !! in [H ~> m or kg m-2] end type p3d !> oda incupd control structure @@ -67,11 +69,12 @@ module MOM_oda_incupd 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, 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 + type(p3d) :: Ref_h !< Vertical grid on which the increments are provided, with data in [H ~> m or kg m-2] integer :: nstep_incupd !< number of time step for full update - real :: ncount = 0.0 !< increment time step counter + real :: ncount = 0.0 !< increment time step counter [nondim]. This could be an integer + !! but a real variable works better with the existing restarts. type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays logical :: incupdDataOngrid !< True if the incupd data are on the model horizontal grid logical :: uv_inc !< use u and v increments @@ -136,7 +139,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: reset_ncount integer :: i, j, k - real :: nhours_incupd, dt, dt_therm + real :: incupd_timescale ! The amount of timer over which to apply the full update [T ~> s] + real :: dt, dt_therm ! Model timesteps [T ~> s] character(len=256) :: mesg character(len=64) :: remapScheme if (.not.associated(CS)) then @@ -153,9 +157,9 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re if (.not.use_oda_incupd) return - call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", nhours_incupd, & + call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", incupd_timescale, & "Number of hours for full update (0=direct insertion).", & - default=3.0,units="h", scale=US%s_to_T) + default=3.0, units="h", scale=3600.0*US%s_to_T) call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & "If True, reinitialize number of updates already done, ncount.", & default=.true.) @@ -199,10 +203,10 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re 'The oda_incupd code only applies ODA increments on the same horizontal grid. ') ! get number of timestep for full update - if (nhours_incupd == 0) then + if (incupd_timescale == 0) then CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( incupd_timescale / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & @@ -243,8 +247,9 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(oda_incupd_CS), pointer :: CS !< oda_incupd control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & - intent(in) :: sp_val !< increment field, it can have an - !! arbitrary number of layers. + intent(in) :: sp_val !< increment field, it can have an arbitrary number + !! of layers, in various units depending on the + !! field it refers to [various]. integer :: i, j, k character(len=256) :: mesg ! String for error messages @@ -524,17 +529,20 @@ 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, 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] + ! Local variables + real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid, in rescaled units + ! like [S ~> ppt] for salinity. + 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 increments [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [S ~> 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(:,:,:) :: h_obs !< h 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] diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index a44eec7727..bfa79ba053 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -643,7 +643,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call pass_vector(u, v, G%Domain) call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) call ML_MEKE_calculate_features(G, GV, US, CS, MEKE%Rd_dx_h, u, v, tv, h, dt, features_array) - call predict_meke(G, CS, SIZE(h), Time, features_array, MEKE%MEKE) + call predict_MEKE(G, CS, SIZE(h), Time, features_array, MEKE%MEKE) case default call MOM_error(FATAL,"Invalid method specified for calculating EKE") end select @@ -1665,12 +1665,14 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) type(time_type), intent(in ) :: Time !< The current model time real(kind=real32), dimension(npts,num_features), intent(in ) :: features_array !< The array of features needed for machine - !! learning inference + !! learning inference, with different units + !! for the various subarrays [various] real, dimension(SZI_(G),SZJ_(G)), intent( out) :: MEKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2] integer :: db_return_code character(len=255), dimension(1) :: model_out, model_in character(len=255) :: time_suffix - real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec + real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec ! A one-dimensional array of eddy kinetic + ! energy [L2 T-2 ~> m2 s-2] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1692,6 +1694,8 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) db_return_code = CS%client%unpack_tensor( model_out(1), MEKE_vec, shape(MEKE_vec) ) call cpu_clock_end(CS%id_unpack_tensor) + !### Does MEKE_vec need to be rescaled from [m2 s-2] to [L2 T-2 ~> m2 s-2] by + ! multiplying MEKE_vec by US%m_s_to_L_T**2 here? MEKE = reshape(MEKE_vec, shape(MEKE)) do j=js,je; do i=is,ie MEKE(i,j) = MIN(MAX(exp(MEKE(i,j)),0.),CS%eke_max) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 6102c2a5ef..e21936ddb4 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -62,7 +62,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [S ~> 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 :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. + real :: rho(SZI_(G),SZJ_(G)) ! A temporary array for mixed layer density [R ~> kg m-3]. real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] @@ -186,10 +186,10 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, EOSdom) + call calculate_density(T(:,j,1), S(:,j,1), pres, rho(:,j), tv%eqn_of_state, EOSdom) enddo - call set_up_sponge_ML_density(tmp, G, CSp) + call set_up_sponge_ML_density(rho, G, CSp) endif ! Apply sponge in tracer fields From b389a89c3b8464de1a6c7081b01f4cb6b2c13ae1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 May 2024 09:26:00 -0400 Subject: [PATCH 009/128] +(*)Fix sign of neutral_slope_x diag with no EOS Corrected the sign convention used for the neutral_slope_x and neutral_slope_y diagnostics in cases when there is not an equation of state being used to match the usual sign convention (interfaces sloping up to the east or north is a positive slope) and to match what is done when an equation of state is being used to calculate neutral density slopes rather than just basing the slopes of the interfaces alone. The same correction was made to the slope_x and slope_y arguments returned from calc_isoneutral_slopes, and self-consistent changes were made to the overturning streamfunction calculations in thickness_diffuse_full. In addition, there were some corrections made to the documentation at the end of MOM_thickness_diffuse.F90, and the calculate_slopes argument to calc_slope_functions_using_just_e() that was always hard-coded to .true. was eliminated to avoid any confusion about whether these changes might propagate beyond the interface height diffusion calculations. This commit addresses most aspects of the issue discussed at github.com/NOAA-GFDL/MOM6/issues/359, although it does not change the sign convention for the overturning streamfunction. All solutions are bitwise identical, but there is a change in the sign convention for two diagnostics and two arguments to a publicly visible interface in pure layer mode when no equation of state is used. --- src/core/MOM_isopycnal_slopes.F90 | 12 +++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 40 ++++++------------- .../lateral/MOM_thickness_diffuse.F90 | 16 ++++---- 3 files changed, 27 insertions(+), 41 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 9defa597ab..a6949e1f40 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -356,8 +356,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = 0.0 endif else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + slope = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) endif + if (local_open_u_BC) then l_seg = OBC%segnum_u(I,j) if (l_seg /= OBC_NONE) then @@ -372,7 +373,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope if (present(dzSxN)) & @@ -504,11 +505,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan else ! Just in case mag_grad2 = 0 ever. slope = 0.0 endif - - else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + slope = (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) endif + if (local_open_v_BC) then l_seg = OBC%segnum_v(i,J) if (l_seg /= OBC_NONE) then @@ -523,7 +523,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope if (present(dzSyN)) & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index defbd78aa7..cd7e235274 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -497,8 +497,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e) endif endif @@ -821,7 +820,7 @@ end subroutine calc_Eady_growth_rate_2D !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] @@ -829,8 +828,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - logical, intent(in) :: calculate_slopes !< If true, calculate slopes - !! internally otherwise use slopes stored in CS ! Local variables real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) @@ -894,28 +891,17 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) do k=nz,CS%VarMix_Ktop,-1 - if (calculate_slopes) then - ! Calculate the interface slopes E_x and E_y and u- and v- points respectively - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) - ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) - ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. - enddo ; enddo - else ! This branch is not used. - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. - enddo ; enddo - endif + ! Calculate the interface slopes E_x and E_y and u- and v- points respectively + do j=js-1,je+1 ; do I=is-1,ie + E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. + enddo ; enddo ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 178e6f76e2..b811f01d94 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1041,10 +1041,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_x) then Slope = slope_x(I,j,k) else - Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) + Slope = ((e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope dzN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -1361,10 +1361,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_y) then Slope = slope_y(i,J,k) else - Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) + Slope = ((e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) dzN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -2451,19 +2451,19 @@ end subroutine thickness_diffuse_end !! to the potential density slope !! \f[ !! \vec{\psi} = - \kappa_h \frac{\nabla_z \rho}{\partial_z \rho} -!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = \kappa_h \frac{M^2}{N^2} +!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = -\kappa_h \frac{M^2}{N^2} !! \f] !! but for robustness the scheme is implemented as !! \f[ -!! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} +!! \vec{\psi} = -\kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} !! \f] -!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! since the quantity \f$\frac{M^2}{\sqrt{N^4 + M^4}}\f$ is bounded between $-1$ and $1$ and does not change sign !! if \f$N^2<0\f$. !! !! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the !! vertically elliptic equation: !! \f[ -!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} +!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = -( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} !! \f] !! which recovers the previous streamfunction relation in the limit that \f$ c \rightarrow 0 \f$. !! Here, \f$c=\max(c_{min},c_g)\f$ is the maximum of either \f$c_{min}\f$ and either the first baroclinic mode From d6500bc0b35c56e71f4a01879d8b38419f112385 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 27 May 2024 07:42:06 -0400 Subject: [PATCH 010/128] +Add DETERMINE_TEMP_CONVERGENCE_BUG parameter Added the new runtime parameter DETERMINE_TEMP_CONVERGENCE_BUG to avoid using layout-dependent tests for temperature and salinity tolerances to determine when to stop iterating in determine_temperature. Also added logic that correctly determines when iterations can be stopped because no further changes occur, and rearranged to loops to avoid revisiting layers that have converged. Because the default tolerances for the temperature, salinity and density changes are set to be the same and the partial derivatives of density with temperature and salinity are less than 1 in the MKS units used here for a realistic equation of state of seawater, this bug does not impact any of the existing regression test cases, but this bug could lead to non-reproducibility with non-default values. This commit changes the entries in the MOM_parameter_doc files that have Z_INIT_ALE_REMAPPING = .false. and FIT_TO_TARGET_DENSITY_IC = .true., by adding a new runtime parameter and by not logging DETERMINE_TEMP_T_TOLERANCE and DETERMINE_TEMP_T_TOLERANCE if they are not used because DETERMINE_TEMP_CONVERGENCE_BUG is false. By default, all answers are bitwise identical. --- src/tracer/MOM_tracer_Z_init.F90 | 101 +++++++++++++++++++------------ 1 file changed, 61 insertions(+), 40 deletions(-) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 2cf0ba1efe..c471b61717 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -464,11 +464,6 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & end subroutine read_Z_edges -!### `find_overlap` and `find_limited_slope` were previously part of -! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in -! `midas_vertmap.F90` with some slight differences. We keep it here for -! reproducibility, but the two should be merged at some point - !> Determines the layers bounded by interfaces e that overlap !! with the depth range between Z_top and Z_bot, and the fractional weights !! of each layer. It also calculates the normalized relative depths of the range @@ -620,15 +615,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. - logical :: adjust_salt, fit_together + logical :: domore(SZK_(GV)) ! Records which layers need additional iterations + logical :: adjust_salt, fit_together, convergence_bug, do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! ### The algorithms of determine_temperature subroutine needs to be reexamined. - - call log_version(PF, mdl, version, "") ! We should switch the default to the newer method which simultaneously adjusts @@ -638,7 +631,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& "match the density by only adjusting temperatures within a maximum range before "//& "revising estimates of the salinity.", default=.false., do_not_log=just_read) - ! These hard coded parameters need to be set properly. + call get_param(PF, mdl, "DETERMINE_TEMP_CONVERGENCE_BUG", convergence_bug, & + "If true, use layout-dependent tests on the changes in temperature and salinity "//& + "to determine when the iterations have converged when DETERMINE_TEMP_ADJUST_T_AND_S "//& + "is false. For realistic equations of state and the default values of the "//& + "various tolerances, this bug does not impact the solutions.", & + default=.true., do_not_log=just_read) !### Change the default to false. + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & "The minimum temperature that can be found by determine_temperature.", & units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) @@ -653,10 +652,12 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & "The convergence tolerance for temperature in determine_temperature.", & - units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=1.0e-4, scale=US%degC_to_C, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & "The convergence tolerance for temperature in determine_temperature.", & - units="ppt", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=1.0e-4, scale=US%ppt_to_S, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & "The convergence tolerance for density in determine_temperature.", & units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) @@ -689,49 +690,69 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) dT(:,:) = 0.0 + domore(:) = .true. adjust_salt = .true. iter_loop: do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R_tgt(k))>tol_rho) then - if (.not.fit_together) then - dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - else - I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then + domore(k) = .true. + if (.not.fit_together) then + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif endif + enddo + endif ; enddo + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop endif - enddo ; enddo - if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit iter_loop ! Further iterations will not change anything. enddo iter_loop if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then - dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - enddo ; enddo - if (maxval(abs(dS)) < tol_S) exit + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + domore(k) = .true. + endif + enddo + endif ; enddo + + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dS)) < tol_S) exit + endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit ! Further iterations will not change anything enddo ; endif temp(:,j,:) = T(:,:) From 9ab5f3483b35a39d15d4d294b9a2a8f6c577ac67 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 May 2024 05:10:03 -0400 Subject: [PATCH 011/128] (*)Fix Kd_interface diag in newer diabatic_ALE Corrected the field being posted for the Kd_interface diagnostic inside of diabatic_ALE() to be the minimum of Kd_heat and Kd_salt, which includes the contributions from ePBL, but excluding any extra double-diffusive mixing, making it analogous to the diagnostic that is currently being posted from layered_diabatic() or diabatic_ALE_legacy(). Diabatic_ALE() is used when USE_REGRIDDING=True and USE_LEGACY_DIABATIC_DRIVER=False, in which case a diagnostic will change, correcting the issue noted at NOAA-GFDL/MOM6/issues/398. All solutions are bitwise identical. --- .../vertical/MOM_diabatic_driver.F90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b450127156..89ed3bada9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1258,9 +1258,6 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif - ! Store the diagnosed typical diffusivity at interfaces. - if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_heat, CS%diag) - ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. if (CS%double_diffuse) then ! Add contributions from double diffusion @@ -1520,6 +1517,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_int > 0) then + if (CS%double_diffuse .or. CS%useKPP) then + do K=1,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = min(Kd_heat(i,j,k), Kd_salt(i,j,k)) + enddo ; enddo ; enddo + endif + call post_data(CS%id_Kd_int, Kd_heat, CS%diag) + endif if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) @@ -3275,8 +3280,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then - CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & From 270ba597a326c10d05e7d0f959a07c01cc920260 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 May 2024 03:53:18 -0400 Subject: [PATCH 012/128] +(*)Fix rotation of coupler_type variables This commit adds the necessary information about the turns of the model grid relative to the (unrotated) coupler_type data fields that are inside of the forcing type and surface_state type and are used with passive tracers, so that certain tracer packages can now be used with rotated grids. The previous version had problems where the model would not run when ROTATE_INTEX = True and the CFCs (and probably other passive tracers) were being used, as noted at NOAA-GFDL/MOM6/issues/621. These problems have now been fixed. There are new calls to coupler_type_spawn() in allocate_forcing_by_ref() and allocate_surface_state() that manage the creation of the coupler_2d_bt_types for unrotated types based on information from their rotated counterparts. There is a new optional turns arguments to allocate_forcing_by_ref() and new optional sfc_state_in and turns arguments to allocate_surface_state(), and these are now being used in at least 6 places where unrotated temporary surface_state or forcing types are being set up. There are also new optional turns argument to extract_coupler_type_data() and set_coupler_type_data() that are used to deal with the fact that the internal data arrays in the coupler_bc_types are never rotated, unlike the other MOM6 arrays, because they have to be passed directly into the generic tracer code. These new turns arguments are used in 14 calls from various tracer packages, including in 6 calls from the OCMIP2_CFC code. There are 4 new calls to deallocate_surface_state() or deallocate_forcing_type() that were added to avoid (presumably minor) memory leaks when grid rotation is enabled. These new calls are in initialize_ice_shelf_fluxes(), shelf_calc_flux() and in the surface flux diagnostics section of step_MOM(). All answers are bitwise identical in any cases that worked previously, but some cases with grid rotation that previously were failing with cryptic error messages are now running successfully. There are new optional arguments to several publicly visible routines. --- src/core/MOM.F90 | 11 ++-- src/core/MOM_forcing_type.F90 | 22 ++++++-- src/core/MOM_variables.F90 | 50 ++++++++++++------ src/framework/MOM_coupler_types.F90 | 71 ++++++++++++++++++++++---- src/ice_shelf/MOM_ice_shelf.F90 | 34 +++++++----- src/tracer/DOME_tracer.F90 | 2 +- src/tracer/ISOMIP_tracer.F90 | 2 +- src/tracer/MOM_OCMIP2_CFC.F90 | 12 ++--- src/tracer/advection_test_tracer.F90 | 2 +- src/tracer/boundary_impulse_tracer.F90 | 2 +- src/tracer/dye_example.F90 | 2 +- src/tracer/ideal_age_example.F90 | 2 +- src/tracer/oil_tracer.F90 | 2 +- src/tracer/tracer_example.F90 | 2 +- 14 files changed, 157 insertions(+), 59 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 397a4e4059..42e675d41f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -624,7 +624,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call rotate_mech_forcing(forces_in, turns, forces) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else forces => forces_in @@ -1044,6 +1044,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then + if (showCallTree) call callTree_waypoint("Do cycle end diagnostics (step_MOM)") if (CS%rotate_index) then allocate(sfc_state_diag) call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) @@ -1063,6 +1064,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) + if (CS%rotate_index) then + call deallocate_surface_state(sfc_state_diag) + endif + if (showCallTree) call callTree_waypoint("Done with end cycle diagnostics (step_MOM)") endif ! Accumulate the surface fluxes for assessing conservation @@ -3710,8 +3715,8 @@ subroutine extract_surface_state(CS, sfc_state_in) if (CS%rotate_index) then allocate(sfc_state) call allocate_surface_state(sfc_state, G, use_temperature, & - do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& - use_iceshelves=use_iceshelves) + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) else sfc_state => sfc_state_in endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 72c67253ed..83b4ea17cd 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -6,7 +6,7 @@ module MOM_forcing_type use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized -use MOM_coupler_types, only : coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_copy_data, coupler_type_spawn use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field @@ -2627,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (turns /= 0) then G => diag%G allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else G => G_in @@ -3308,13 +3308,16 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & end subroutine allocate_forcing_by_group !> Allocate elements of a new forcing type based on their status in an existing type. -subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns) type(forcing), intent(in) :: fluxes_ref !< Reference fluxes type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes type(forcing), intent(out) :: fluxes !< Target fluxes + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise + !! quarter turns to use on the new grid. logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf logical :: do_iceberg, do_heat_added, do_buoy + logical :: even_turns ! True if turns is absent or even call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) @@ -3353,6 +3356,19 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) ! This flag would normally be set by a control flag in allocate_forcing_type. ! Here we copy the flag from the reference forcing. fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug + + if (coupler_type_initialized(fluxes_ref%tr_fluxes)) then + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%isc,G%isc,G%iec,G%iec/), (/G%jsc,G%jsc,G%jec,G%jec/)) + else + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%jsc,G%jsc,G%jec,G%jec/), (/G%isc,G%isc,G%iec,G%iec/)) + endif + endif + end subroutine allocate_forcing_by_ref diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index d5d20f0400..37c1607826 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -339,14 +339,14 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil) + omit_frazil, sfc_state_in, turns) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically !! integrated fields. type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related @@ -356,9 +356,20 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler + type(surface), & + optional, intent(in) :: sfc_state_in !< If present and its tr_fields are initialized, + !! this type describes the ocean and surface-ice fields that + !! will participate in the calculation of additional gas or + !! other tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. If gas_fields_ocn + !! is present, it is used and tr_fields_in is ignored. + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise quarter + !! turns to use on the new grid. ! local variables logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil + logical :: even_turns ! True if turns is absent or even + integer :: tr_field_i_mem(4), tr_field_j_mem(4) integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -406,9 +417,22 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB), source=0.0) endif - if (present(gas_fields_ocn)) & + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + tr_field_i_mem(1:4) = (/is,is,ie,ie/) ; tr_field_j_mem(1:4) = (/js,js,je,je/) + else + tr_field_i_mem(1:4) = (/js,js,je,je/) ; tr_field_j_mem(1:4) = (/is,is,ie,ie/) + endif + if (present(gas_fields_ocn)) then call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + elseif (present(sfc_state_in)) then + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_spawn(sfc_state_in%tr_fields, sfc_state%tr_fields, & + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + endif + endif sfc_state%arrays_allocated = .true. @@ -439,10 +463,10 @@ end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) - type(surface), intent(in) :: sfc_state_in - type(surface), intent(inout) :: sfc_state - type(ocean_grid_type), intent(in) :: G - integer, intent(in) :: turns + type(surface), intent(in) :: sfc_state_in !< The input unrotated surface state type that is the data source. + type(surface), intent(inout) :: sfc_state !< The rotated surface state type whose arrays will be filled in + type(ocean_grid_type), intent(in) :: G !< The ocean grid structure + integer, intent(in) :: turns !< The number of counterclockwise quarter turns to use on the rotated grid. logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves @@ -455,13 +479,9 @@ subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) .and. allocated(sfc_state_in%tauy_shelf) if (.not. sfc_state%arrays_allocated) then - call allocate_surface_state(sfc_state, G, & - use_temperature=use_temperature, & - do_integrals=do_integrals, & - use_meltpot=use_melt_potential, & - use_iceshelves=use_iceshelves & - ) - sfc_state%arrays_allocated = .true. + call allocate_surface_state(sfc_state, G, use_temperature=use_temperature, & + do_integrals=do_integrals, use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) endif if (use_temperature) then diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 1baef24f76..b931a2ddd2 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -3,6 +3,7 @@ module MOM_coupler_types ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data @@ -363,7 +364,7 @@ end subroutine coupler_type_data_override !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract !! The internal data has arbitrary units [B]. integer, intent(in) :: bc_index !< The index of the boundary condition @@ -384,13 +385,35 @@ subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, integer, optional, intent(in) :: field_index !< The index of the field in the boundary !! condition that is being copied, or the !! surface flux by default. - - if (present(field_index)) then - call CT_extract_data(var_in, bc_index, field_index, array_out, & + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in arbitrary units [A] + integer :: q_turns ! The number of quarter turns through which array_out is to be rotated + integer :: index, is, ie, js, je, halo + + index = ind_flux ; if (present(field_index)) index = field_index + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_extract_data(var_in, bc_index, index, array_out, & scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_out(is:ie,js:je), [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out(is:ie,js:je)) + deallocate(array_unrot) else - call CT_extract_data(var_in, bc_index, ind_flux, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + call allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out) + deallocate(array_unrot) endif end subroutine extract_coupler_type_data @@ -398,7 +421,7 @@ end subroutine extract_coupler_type_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a !! MOM-specific interface. subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field in !! arbitrary units [A]; the size of this array !! must match the size of the data being copied @@ -422,15 +445,43 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being set. The !! surface concentration is set by default. + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in the same arbitrary units + ! as array_in [A] integer :: subfield ! An integer indicating which field to set. + integer :: q_turns ! The number of quarter turns through which array_in is rotated + integer :: is, ie, js, je, halo + + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) subfield = ind_csurf if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif if (present(field_index)) subfield = field_index - - call CT_set_data(array_in, bc_index, subfield, var, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_in(is:ie,js:je), [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_unrot, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + else + call allocate_rotated_array(array_in, [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + endif end subroutine set_coupler_type_data diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 05c70a0ea1..a4b06b6150 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -41,9 +41,9 @@ module MOM_ice_shelf use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling -use MOM_variables, only : surface, allocate_surface_state +use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state -use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum +use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input @@ -378,7 +378,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) allocate(sfc_state) call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else sfc_state => sfc_state_in @@ -916,14 +916,17 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) call cpu_clock_end(id_clock_shelf) + if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) + if (CS%rotate_index) then ! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) - call rotate_forcing(fluxes,fluxes_in,-CS%turns) + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_surface_state(sfc_state) + deallocate(sfc_state) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) endif - - if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) - end subroutine shelf_calc_flux subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out) @@ -1723,14 +1726,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then - allocate(sfc_state) ! assuming frazil is enabled in ocean. This could break some configurations? call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) else - sfc_state=>sfc_state_in + sfc_state => sfc_state_in endif endif @@ -2103,14 +2106,14 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) 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., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) + press=.true., shelf_sfc_accumulation=CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else - fluxes=>fluxes_in + fluxes => fluxes_in endif do j=jsd,jed ; do i=isd,ied @@ -2119,8 +2122,11 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call add_shelf_pressure(ocn_grid, US, CS, fluxes) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif end subroutine initialize_ice_shelf_fluxes diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index e0bd659a60..76546f834c 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -372,7 +372,7 @@ subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 64db56b96c..cc4dca16bc 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -331,7 +331,7 @@ subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 50354b5dc7..7947cc72ed 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -453,9 +453,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The -GV%Rho0 changes the sign convention of the flux and with the scaling factors changes ! the units of the flux from [Conc. m s-1] to [Conc. R Z T-1 ~> Conc. kg m-2 s-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -587,13 +587,13 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index d8eb4d57fb..567c706de0 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -329,7 +329,7 @@ subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index b8ed0632a2..0698d7f9cc 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -340,7 +340,7 @@ subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index ff2199fc80..2cc4654691 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -395,7 +395,7 @@ subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4323479823..cd781169af 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -559,7 +559,7 @@ subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 22310b5802..1260711347 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -466,7 +466,7 @@ subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index fa9b978f9c..ff2812b8ee 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -427,7 +427,7 @@ subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif From b56a6400f70cf7923f29046013056fb1c0c27b5d Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 6 May 2024 11:12:22 -0400 Subject: [PATCH 013/128] Deallocate eta_av_bc in MOM_end() --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 42e675d41f..d37f265030 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4218,7 +4218,7 @@ subroutine MOM_end(CS) if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) - DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) ; DEALLOC_(CS%eta_av_bc) ! TODO: debug_truncations deallocation From 85212229cdf394ae5dc14435dfa59b31118b0124 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 16 May 2024 12:08:30 -0400 Subject: [PATCH 014/128] Fix warning message indices in MOM_barotropic The "eta has dropped below bathT" warning message has indices off by 1. This is because G%isd_global = G%isd + HI%idg_offset and G%isd is (most of the time) 1. G%isd_global/G%jsd_global are now replaced by G%HI%idg_offset/G%HI%jdg_offset. --- src/core/MOM_barotropic.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 83bfab0820..8cdd90ee58 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2443,7 +2443,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & - -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%isd_global, j + G%jsd_global + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset if (err_count < 2) & call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) err_count = err_count + 1 From a2960801153094c99eda376434c374ecbbeac2d4 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 16 May 2024 13:10:39 -0400 Subject: [PATCH 015/128] Normalize wt_[uv] in MOM_barotropic Add an option to normalize wt_[uv] in the barotropic solver. This is fix step 1 of 2 to address the issue that visc_rem is applied incorrectly to the barotropic solver. A runtime flag BAROTROPIC_VERTICAL_WEIGHT_FIX is added to control the behavior of this commit. The current default is false (not applying the fix). --- src/core/MOM_barotropic.F90 | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 8cdd90ee58..e0e46e4736 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -282,6 +282,7 @@ module MOM_barotropic logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed !! consistent with tidal self-attraction and loading !! used within the barotropic solver + logical :: wt_uv_fix !< If true, use a normalized wt_[uv] for vertical averages. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -506,6 +507,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with ! sums less than one due to viscous losses [nondim] + real :: Iwt_u_tot(SZIB_(G),SZJ_(G)) ! Iwt_u_tot and Iwt_v_tot are the + real :: Iwt_v_tot(SZI_(G),SZJB_(G)) ! inverses of wt_u and wt_v vertical integrals, + ! used to normalize wt_u and wt_v [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u [nondim] tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim] @@ -1052,6 +1056,30 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem enddo ; enddo ; enddo + if (CS%wt_uv_fix) then + do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo + do k=2,nz ; do j=js,je ; do I=is-1,ie + Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) + enddo ; enddo ; enddo + do j=js,je ; do I=is-1,ie + Iwt_u_tot(I,j) = G%mask2dCu(I,j) / (Iwt_u_tot(I,j) + h_neglect) + enddo ; enddo + do k=1,nz ; do j=js,je ; do I=is-1,ie + wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j) + enddo ; enddo ; enddo + + do J=js-1,je ; do i=is,ie ; Iwt_v_tot(i,J) = wt_v(i,J,1) ; enddo ; enddo + do k=2,nz ; do J=js-1,je ; do i=is,ie + Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k) + enddo ; enddo ; enddo + do J=js-1,je ; do i=is,ie + Iwt_v_tot(i,J) = G%mask2dCv(i,J) / (Iwt_v_tot(i,J) + h_neglect) + enddo ; enddo + do k=1,nz ; do J=js-1,je ; do i=is,ie + wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J) + enddo ; enddo ; enddo + endif + ! Use u_Cor and v_Cor as the reference values for the Coriolis terms, ! including the viscous remnant. !$OMP parallel do default(shared) @@ -4580,10 +4608,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values uuse more efficient or general expressions.", & + "while higher values use more efficient or general expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "BAROTROPIC_VERTICAL_WEIGHT_FIX", CS%wt_uv_fix, & + "If true, use a normalized weight function for vertical averages of "//& + "baroclinic velocity and forcing.", & + default=.false.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & From 66e8891a9b40fdb335043153a572889bab703dfa Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 16 May 2024 13:49:38 -0400 Subject: [PATCH 016/128] Use dt for vertvisc_remnant() in predictor Add an option to use `dt` instead of `dt_pred` in the calculation of vertvisc_remnant() at the end of predictor stage. The change affects the following `continuity`() call and `btstep`() call in corrector step. Combined with the changes from the previous commit, the new options should solve the issue of inconsistent barotropic velocities from barotropic solver and baroclinic step. A runtime flag VISC_REM_TIMESTEP_FIX is added to control the behavior of this commit. The current default is false (not applying the fix). --- src/core/MOM_barotropic.F90 | 4 ++-- src/core/MOM_dynamics_split_RK2.F90 | 12 +++++++++++- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e0e46e4736..abed8be16f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4614,8 +4614,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BAROTROPIC_VERTICAL_WEIGHT_FIX", CS%wt_uv_fix, & "If true, use a normalized weight function for vertical averages of "//& - "baroclinic velocity and forcing.", & - default=.false.) + "baroclinic velocity and forcing. This flag should be used with "//& + "VISC_REM_TIMESTEP_FIX.", default=.false.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b315916ec5..aa7ebc6e11 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 logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs integer :: id_uold = -1, id_vold = -1 @@ -725,7 +726,11 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_fix) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -1414,6 +1419,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & + "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& + "predictor stage for the following continuity() call and btstep() call "//& + "in the corrector step. This flag should be used with "//& + "BAROTROPIC_VERTICAL_WEIGHT_FIX,", default=.false.) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) From 337ee7315946695b596c46235ce110cde556698c Mon Sep 17 00:00:00 2001 From: He Wang Date: Fri, 17 May 2024 09:40:37 -0400 Subject: [PATCH 017/128] Fix a typo in USE_CONT_THICKNESS description --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2eef171bf5..c181cd4ad8 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2062,7 +2062,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & - "If true, use thickness at velocity points from continuity solver. This option"//& + "If true, use thickness at velocity points from continuity solver. This option "//& "currently only works with split mode.", default=.false.) call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & From 1d2911f337ffb0fcce15fba40aea41e59185f8fe Mon Sep 17 00:00:00 2001 From: He Wang Date: Wed, 22 May 2024 15:23:03 -0400 Subject: [PATCH 018/128] Remove visc_rem from h_[uv] in continuity solver This commit is the third fix related to visc_rem in split mode. h_[uv] from `zonal_flux_thickness`() and `meridional_flux_thickness`() is currently multiplied by `visc_rem_[uv]`. This seems to be double-counting as `visc_rem_[uv]` is accounted for in the barotropic solver vertical weights. Moreover, for options other than BT_cont, the velocity point thickness does not include visc_rem. The fix removes the visc_rem factor from h_[uv] when BT_cont is used. A runtime flag VISC_REM_CONT_HVEL_FIX is added to control the behavior of this commit. The current default is false (not applying the fix). Other small changes: * Write out explicitly all keyword arguments in `continuity`() calls in MOM_dynamics_split_RK2. * Rename a runtime parameter BAROTROPIC_VERTICAL_WEIGHT_FIX from a previous commit to VISC_REM_BT_WEIGHT_FIX, to be consistent with the style of the other two flags. * Add VISC_REM_TIMESTEP_FIX parameter to MOM_dynamics_split_RK2b --- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_continuity_PPM.F90 | 47 +++++++++++++++++++++------- src/core/MOM_dynamics_split_RK2.F90 | 9 +++--- src/core/MOM_dynamics_split_RK2b.F90 | 12 ++++++- 4 files changed, 53 insertions(+), 17 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index abed8be16f..fb343978fc 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4612,7 +4612,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) - call get_param(param_file, mdl, "BAROTROPIC_VERTICAL_WEIGHT_FIX", CS%wt_uv_fix, & + call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_FIX", CS%wt_uv_fix, & "If true, use a normalized weight function for vertical averages of "//& "baroclinic velocity and forcing. This flag should be used with "//& "VISC_REM_TIMESTEP_FIX.", default=.false.) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index ba8c234bc2..31464c22f0 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -64,6 +64,9 @@ module MOM_continuity_PPM !! continuity solver for use as the weights in the !! barotropic solver. Otherwise use the transport !! averaged areas. + logical :: visc_rem_hvel_fix = .False. !< If true, thickness at velocity points + !! h_[uv] (used by barotropic solver) is not multiplied + !! by visc_rem_[uv]. end type continuity_PPM_CS !> A container for loop bounds @@ -806,12 +809,22 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + if (CS%visc_rem_hvel_fix) then + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) + else + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) + endif else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + else + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + endif endif endif ; endif @@ -1696,12 +1709,22 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then - if (present(v_cor)) then - call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + if (CS%visc_rem_hvel_fix) then + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) + else + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) + endif else - call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + else + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + endif endif endif ; endif @@ -2750,7 +2773,9 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, use the marginal face areas from the continuity "//& "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) - + call get_param(param_file, mdl, "VISC_REM_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & + "If true, velocity cell thickness h_[uv] from the continuity solver "//& + "is not multiplied by visc_rem_[uv].", default=.false.) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index aa7ebc6e11..57e118b47f 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -744,8 +744,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! hp = h + dt * div . uh call cpu_clock_begin(id_clock_continuity) call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & - u_av, v_av, BT_cont=CS%BT_cont) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") @@ -999,7 +999,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) ! Whenever thickness changes let the diag manager know, target grids @@ -1423,7 +1424,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& "predictor stage for the following continuity() call and btstep() call "//& "in the corrector step. This flag should be used with "//& - "BAROTROPIC_VERTICAL_WEIGHT_FIX,", default=.false.) + "VISC_REM_BT_WEIGHT_FIX.", default=.false.) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index e55e2e3f96..cadd976455 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -174,6 +174,7 @@ module MOM_dynamics_split_RK2b logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs ! integer :: id_uold = -1, id_vold = -1 @@ -742,7 +743,11 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_fix) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -1330,6 +1335,11 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & + "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& + "predictor stage for the following continuity() call and btstep() call "//& + "in the corrector step. This flag should be used with "//& + "VISC_REM_BT_WEIGHT_FIX.", default=.false.) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) From 09774d410007b98e4ebcf938ed39d138213c5ab7 Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 3 Jun 2024 16:06:27 -0400 Subject: [PATCH 019/128] Use Adcroft_reciprocal for Iwt_[uv]_tot * Correct a bug using dimensional h_neglect in calculating non-dimensional Iwt_[uv]_tot, by replacing the division with an Adcroft_reciprocal style division. * Add a parameter VISC_REM_BUG to control the defaults of all three viscous remnant bug related parameters. The individual parameters should be removed in the future. --- src/core/MOM_barotropic.F90 | 11 +++++++---- src/core/MOM_continuity_PPM.F90 | 5 ++++- src/core/MOM_dynamics_split_RK2.F90 | 10 +++++++++- src/core/MOM_dynamics_split_RK2b.F90 | 12 ++++++++++-- 4 files changed, 30 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index fb343978fc..2d463b909c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1062,7 +1062,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) enddo ; enddo ; enddo do j=js,je ; do I=is-1,ie - Iwt_u_tot(I,j) = G%mask2dCu(I,j) / (Iwt_u_tot(I,j) + h_neglect) + if (abs(Iwt_u_tot(I,j)) > 0.0 ) Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j) enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j) @@ -1073,7 +1073,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k) enddo ; enddo ; enddo do J=js-1,je ; do i=is,ie - Iwt_v_tot(i,J) = G%mask2dCv(i,J) / (Iwt_v_tot(i,J) + h_neglect) + if (abs(Iwt_v_tot(i,J)) > 0.0 ) Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J) enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J) @@ -4464,6 +4464,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: use_BT_cont_type logical :: use_tides + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4612,10 +4613,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_FIX", CS%wt_uv_fix, & "If true, use a normalized weight function for vertical averages of "//& - "baroclinic velocity and forcing. This flag should be used with "//& - "VISC_REM_TIMESTEP_FIX.", default=.false.) + "baroclinic velocity and forcing. Default of this flag is set by "//& + "VISC_REM_BUG. This flag should be used with VISC_REM_TIMESTEP_FIX.", & + default=.not.visc_rem_bug) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 31464c22f0..cedcdc573b 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -2713,6 +2713,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. CS%initialized = .true. @@ -2773,9 +2774,11 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, use the marginal face areas from the continuity "//& "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) call get_param(param_file, mdl, "VISC_REM_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & "If true, velocity cell thickness h_[uv] from the continuity solver "//& - "is not multiplied by visc_rem_[uv].", default=.false.) + "is not multiplied by visc_rem_[uv]. Default of this flag is set by "//& + "VISC_REM_BUG.", default=.not.visc_rem_bug) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 57e118b47f..daabc8d135 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1353,6 +1353,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1420,11 +1421,18 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in three places. This parameter controls the defaults of three individual "//& + "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& + "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& + "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& + "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& "predictor stage for the following continuity() call and btstep() call "//& "in the corrector step. This flag should be used with "//& - "VISC_REM_BT_WEIGHT_FIX.", default=.false.) + "VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index cadd976455..e16c10cde6 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -1277,6 +1277,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, character(len=48) :: thickness_units, flux_units, eta_rest_name logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1335,11 +1336,18 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in three places. This parameter controls the defaults of three individual "//& + "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& + "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& + "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& + "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& "predictor stage for the following continuity() call and btstep() call "//& - "in the corrector step. This flag should be used with "//& - "VISC_REM_BT_WEIGHT_FIX.", default=.false.) + "in the corrector step. Default of this flag is set by VISC_REM_BUG. "//& + "This flag should be used with VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) From 215b9609cd8bba243d7f928e945158f2e015ba03 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 12 May 2024 05:49:28 -0400 Subject: [PATCH 020/128] Refactor PressureForce_FV before ice shelf fixes Refactored PressureForce_FV_nonBouss and PressureForce_FV_Bouss to use more 3-dimensional arrays in preparation for the changes that we are expecting from Claire Yung to reduce the pressure gradient errors in ice shelf cavities. These anticipated changes will involve selecting an internal interface at which to define the shape of the interfaces with depth when there is an ice shelf, rather than assuming that the top surface pressure varies linearly with depth between the two top corners. In PressureForce_FV_nonBouss, this refactoring includes turning za, intx_za and inty_za into 3-d arrays and moving the code setting these arrays outside of the k-loop setting the pressure gradient forces. Changes in PressureForce_FV_Bouss are analogous but involve turning 7 arrays (pa, dpa, intz_dpa, intx_pa, intx_dpa, inty_pa and inty_dpa) into 3-d arrays. In both cases, the code for a reduced gravity model is consolidated into a single block toward the end of the routines. These changes to use more 3-d arrays could increase the computational time for the pressure gradient calculations, but in short regression tests any such increase in computational time appears to be small. No external interfaces are changed, and all answers are bitwise identical. --- src/core/MOM_PressureForce_FV.F90 | 318 +++++++++++++++++------------- 1 file changed, 181 insertions(+), 137 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 5fb3ade634..5d0f4ff167 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -128,21 +128,22 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to + dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> m2 s-2]. + ! interfaces [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. - real, dimension(SZIB_(G),SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & intx_za ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & inty_za ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -305,10 +306,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j,nz+1) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) + dza(i,j,k) + za(i,j,K) = za(i,j,K+1) + dza(i,j,k) enddo ; enddo enddo @@ -316,7 +317,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) @@ -324,7 +325,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif endif @@ -335,7 +336,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + za(i,j,1) = za(i,j,1) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo else ! This block recreates older answers with tides. if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 @@ -343,85 +344,104 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal_tide(i,j) enddo ; enddo endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) private(rho_in_situ) - do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & - tv%eqn_of_state, EOSdom) - - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) - enddo ; enddo - endif -! else -! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo - endif + ! Find the height anomalies at the interfaces. If there are no tides and no SAL, + ! there is no need to correct za, but omitting this changes answers at roundoff. + do k=1,nz + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,K+1) = za(i,j,K) - dza(i,j,k) + enddo ; enddo + enddo ! This order of integrating upward and then downward again is necessary with ! a nonlinear equation of state, so that the surface geopotentials will go - ! linearly between the values at thickness points, but the bottom - ! geopotentials will not now be linear at the sub-grid-scale. Doing this - ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. + ! linearly between the values at thickness points, but the bottom geopotentials + ! will not now be linear at the sub-grid-scale. Doing this ensures no motion + ! with flat isopycnals, even with a nonlinear equation of state. + ! With an ice-shelf or icebergs, this linearity condition might need to be applied + ! to a sub-surface interface. !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) enddo ; enddo + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K+1) = intx_za(I,j,K) - intx_dza(I,j,k) + enddo ; enddo + enddo + !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) enddo ; enddo do k=1,nz - ! These expressions for the acceleration have been carefully checked in - ! a set of idealized cases, and should be bug-free. !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K+1) = inty_za(i,J,K) - inty_dza(i,J,k) + enddo ; enddo + enddo + + !$OMP parallel do default(shared) private(dp) + do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = H_to_RL2_T2 * h(i,j,k) - za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo - !$OMP parallel do default(shared) + + ! Find the horizontal pressure gradient accelerations. + ! These expressions for the accelerations have been carefully checked in + ! a set of idealized cases, and should be bug-free. do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) - PFu(I,j,k) = ( ((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & - ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + PFu(I,j,k) = ( ((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j,K+1)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j,K+1) - & (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k)) ) * & (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + dp_neglect)) enddo ; enddo - !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) - PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & - ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + PFv(i,J,k) = (((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1,K+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J,K+1) - & (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + dp_neglect)) enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, EOSdom) - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j,1)) + enddo + enddo + else !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j,1)) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo - endif - enddo + enddo + endif if (present(pbce)) then call set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce) @@ -493,20 +513,24 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. - pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + dz_geo ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + pa ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dpa, & ! The change in pressure anomaly between the top and bottom ! of a layer [R L2 T-2 ~> Pa]. intz_dpa ! The vertical integral in depth of the pressure anomaly less the ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - intx_pa, & ! The zonal integral of the pressure anomaly along the interface + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + intx_pa ! The zonal integral of the pressure anomaly along the interface ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJB_(G)) :: & - inty_pa, & ! The meridional integral of the pressure anomaly along the + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + inty_pa ! The meridional integral of the pressure anomaly along the ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & @@ -648,17 +672,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo ; enddo if (use_EOS) then -! With a bulk mixed layer, replace the T & S of any layers that are -! lighter than the buffer layer with the properties of the buffer -! layer. These layers will be massless anyway, and it avoids any -! formal calculations with hydrostatically unstable profiles. - if (nkmb>0) then + ! With a bulk mixed layer, replace the T & S of any layers that are lighter than the buffer + ! layer with the properties of the buffer layer. These layers will be massless anyway, and + ! it avoids any formal calculations with hydrostatically unstable profiles. tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo - !$OMP parallel do default(shared) private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -680,31 +702,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - if (use_p_atm) then - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & - tv%eqn_of_state, EOSdom) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, EOSdom) - endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) - enddo ; enddo - endif - endif - ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. - ! If regridding is activated, do a linear reconstruction of salinity ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees @@ -723,22 +720,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) - enddo ; enddo do k=1,nz ! Calculate 4 integrals through the layer that are required in the @@ -753,76 +742,131 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if ( CS%Recon_Scheme == 1 ) then call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp, & use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, Z_0p=G%Z_ref) + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & + intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & + CS%useMassWghtInterp, Z_0p=G%Z_ref) + endif + if (GV%Z_to_H /= 1.0) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H + enddo ; enddo endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H - enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) - intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) + dpa(i,j,k) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) + intx_dpa(I,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + inty_dpa(i,J,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) enddo ; enddo endif + enddo - ! Compute pressure gradient in x direction + ! Set the pressure anomalies at the interfaces. + do k=1,nz !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdxCu(I,j)) / & - ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) - intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k) enddo ; enddo - ! Compute pressure gradient in y direction + enddo + + ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, + ! assuming that the surface pressure anomaly varies linearly in x and y. + ! If there is an ice-shelf or icebergs, this linear variation would need to be applied + ! to an interior interface. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + enddo ; enddo + do k=1,nz !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdyCv(i,J)) / & - ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) - inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k) enddo ; enddo + enddo + + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + enddo ; enddo + do k=1,nz !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = pa(i,j) + dpa(i,j) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K+1) = inty_pa(i,J,K) + inty_dpa(i,J,k) enddo ; enddo enddo + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i+1,j,K)*h(i+1,j,k) + intz_dpa(i+1,j,k))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j,K) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + enddo ; enddo ; enddo + + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i,j+1,K)*h(i,j+1,k) + intz_dpa(i,j+1,k))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J,K) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + enddo ; enddo ; enddo + if (CS%GFS_scale < 1.0) then - do k=1,nz + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, EOSdom) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, EOSdom) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo From 31afce04b6fe7f70992ff49f08db197debc0c123 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 May 2024 05:51:09 -0400 Subject: [PATCH 021/128] (*)Avoid diagnostic seg fault in a 10km deep ocean It was noted in NOAA-GFDL/MOM6/issues/491 that the call to initialize_regridding() for diagnostics gives a segmentation fault when the maximum depth of the ocean is greater than 9250 m unless DIAG_COORD_DEF_Z is explicitly set. This commit fixes this problem by (1) adding an extra layer to the bottom of the hard-coded WOA09 list of diagnostic depths when the ocean is deeper than the 9250 m maximum depth in that file, and (2) changing the default behavior for diagnostic grids to be be uniform when the maximum ocean depth is deeper than 9250 m, for which WOA09 is no longer likely to be a convenient choice. With this change, MOM6 no longer has segmentation faults for the configuration described in issues/491. All solutions are bitwise identical, but some z-space diagnostic grids will be modified in cases that previously had segmentation faults. --- src/ALE/MOM_regridding.F90 | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8faec6c495..43d3f65a5e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -211,6 +211,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: tmpReal ! A temporary variable used in setting other variables [various] real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). + real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when + ! maximum_depth is large [m] (not in Z). real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] @@ -311,7 +313,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = create_coord_param(param_prefix, "DEF", param_suffix) coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) string2 = 'UNIFORM' - if (maximum_depth>3000.) string2='WOA09' ! For convenience + if ((maximum_depth>3000.) .and. (maximum_depth<9250.)) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & "Determines how to specify the coordinate "//& @@ -458,20 +460,27 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then - tmpReal = 0. ; ke = 0 + tmpReal = 0. ; ke = 0 ; dz_extra = 0. do while (tmpReal size(woa09_dz)) then + dz_extra = maximum_depth - tmpReal + exit + endif tmpReal = tmpReal + woa09_dz(ke) enddo elseif (index(trim(string),'WOA09:')==1) then if (len_trim(string)==6) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Expected string of form "WOA09:N" but got "'//trim(string)//'".') ke = extract_integer(string(7:len_trim(string)),'',1) + if (ke>40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05:N" N must 040 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'For "WOA05:N" N must 0 size(woa09_dz)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized coordinate configuration"//trim(string)) From 36dda7e4ec1a1ca7b17b4d83feda336803a9b2f1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 May 2024 10:26:21 -0400 Subject: [PATCH 022/128] +Add BACKSCATTER_UNDERBOUND Added the new runtime parameter BACKSCATTER_UNDERBOUND that can be set to false to avoid a potential source of numerical instabilities from excessively large biharmonic viscosities due to overly generous bounds where there are negative Laplacian viscosities due to backscatter parameterizations. Setting this to true reproduces the previous solutions, while setting it to false treats negative and zero Laplacian viscosities the same way when bounding the biharmonic viscosity. When the Laplacian viscosities are all non-negative, the value of BACKSCATTER_UNDERBOUND makes no difference. The default is true for historical reasons, but this option probably should be set to false to avoid certain numerical instabilities from the horizontal viscosities. By default, all answers are bitwise identical, but there are new entries in MOM_parameter_doc files for cases that set both BETTER_BOUND_KH and BETTER_BOUND_AH to true. --- .../lateral/MOM_hor_visc.F90 | 62 ++++++++++++------- 1 file changed, 39 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c181cd4ad8..e72b2097f8 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -60,6 +60,12 @@ module MOM_hor_visc !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. !! The default is 0.8. + logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed + !! to increase where the Laplacian viscosity is negative (due to + !! backscatter parameterizations) beyond the largest timestep-dependent + !! stable values of biharmonic viscosity when no Laplacian viscosity is + !! applied. The default is true for historical reasons, but this option + !! probably should not be used as it can lead to numerical instabilities. logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy !! viscosity. KH is the background value. logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky @@ -382,6 +388,7 @@ 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_max_here ! The local maximum Laplacian viscosity for stability [L2 T-1 ~> m2 s-1] 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]. @@ -628,8 +635,8 @@ 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 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 sh_xx_sq, sh_xy_sq, meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, & + !$OMP h_min, hrat_min, visc_bound_rem, Kh_max_here, & !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & @@ -1064,12 +1071,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) enddo ; enddo - - if (CS%better_bound_Kh) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - visc_bound_rem(i,j) = 1.0 - enddo ; enddo - endif endif if (CS%Laplacian) then @@ -1153,15 +1154,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Newer method of bounding for stability - if (CS%better_bound_Kh) then + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then + visc_bound_rem(i,j) = 1.0 + Kh_max_here = hrat_min(i,j) * CS%Kh_Max_xx(i,j) + if (Kh(i,j) >= Kh_max_here) then visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) - 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)) + Kh(i,j) = Kh_max_here + elseif ((Kh(i,j) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / Kh_max_here endif enddo ; enddo + elseif (CS%better_bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = min(Kh(i,j), hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + enddo ; enddo endif ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. @@ -1428,11 +1435,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect)) enddo ; enddo - if (CS%better_bound_Kh) then - do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(I,J) = 1.0 - enddo ; enddo - endif endif if (CS%no_slip) then @@ -1543,13 +1545,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then + visc_bound_rem(I,J) = 1.0 + Kh_max_here = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + if (Kh(I,J) >= Kh_max_here) 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)) + Kh(I,J) = Kh_max_here + elseif ((Kh(I,J) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(I,J) = 1.0 - Kh(I,J) / Kh_max_here endif + elseif (CS%better_bound_Kh) then + Kh(I,J) = min(Kh(I,J), hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points @@ -2208,6 +2214,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "so that the biharmonic Reynolds number is equal to this.", & units="nondim", default=0.0, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "BACKSCATTER_UNDERBOUND", CS%backscatter_underbound, & + "If true, the bounds on the biharmonic viscosity are allowed to "//& + "increase where the Laplacian viscosity is negative (due to backscatter "//& + "parameterizations) beyond the largest timestep-dependent stable values of "//& + "biharmonic viscosity when no Laplacian viscosity is applied. The default "//& + "is true for historical reasons, but this option probably should not be used "//& + "because it can contribute to numerical instabilities.", & + default=.true., do_not_log=.not.((CS%better_bound_Kh).and.(CS%better_bound_Ah))) + !### The default for BACKSCATTER_UNDERBOUND should be false. + call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & From f798796872a618d5179f6360984119b026d0e316 Mon Sep 17 00:00:00 2001 From: Wenda Zhang <42078272+Wendazhang33@users.noreply.github.com> Date: Thu, 20 Jun 2024 19:45:29 -0400 Subject: [PATCH 023/128] Correct the computation of FrictWork in MOM_hor_visc Add FRICTWORK_BUG parameter (default is true). If FRICTWORK_BUG is false, use the new way to compute FrictWork using the thickness flux. The previous version (realized by setting FRICTWORK_BUG as true) uses the velocity to compute FrictWork, which overestimates the total energy dissipation rate compared with the domain integral of KE_horvisc computed in MOM_diagnostics. --- src/core/MOM_dynamics_split_RK2.F90 | 4 +- src/core/MOM_dynamics_split_RK2b.F90 | 6 +- src/core/MOM_dynamics_unsplit.F90 | 2 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- .../lateral/MOM_hor_visc.F90 | 90 +++++++++++++++++-- 5 files changed, 89 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index daabc8d135..671f707583 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -846,7 +846,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) @@ -1530,7 +1530,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p 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, & + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call set_initialized(CS%diffu, "diffu", restart_CS) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index e16c10cde6..9c5c248c3c 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -553,7 +553,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -843,8 +843,8 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 579ddead2d..72c7dbe6cd 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -263,7 +263,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 65b3bdf50e..cc37f1c2bc 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -275,7 +275,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & + call horizontal_viscosity(u_in, v_in, h_in, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e72b2097f8..b9e50f6b80 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -94,6 +94,8 @@ module MOM_hor_visc !! in setting the corner-point viscosities when USE_KH_BG_2D=True. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. + logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork, + !! which cancels the h in thickness flux and the h at velocity point. logical :: use_land_mask !< Use the land mask for the computation of thicknesses !! at velocity locations. This eliminates the dependence on !! arbitrary values over land or outside of the domain. @@ -247,7 +249,7 @@ module MOM_hor_visc !! u(is-2:ie+2,js-2:je+2) !! v(is-2:ie+2,js-2:je+2) !! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options. -subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & +subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GV, US, & CS, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -257,6 +259,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< The zonal volume transport [H L2 T-1 ~> m3 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< The meridional volume transport [H L2 T-1 ~> m3 s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] @@ -615,7 +621,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP parallel do default(none) & !$OMP shared( & - !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, uh, vh, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & @@ -1787,10 +1793,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo endif - if (find_FrictWork) then ; do j=js,je ; do i=is,ie + if (find_FrictWork) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie ! 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 * ( & + 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) * & @@ -1805,12 +1812,44 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + 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 + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo ; endif + endif - if (CS%use_GME) then ; do j=js,je ; do i=is,ie + + if (CS%use_GME) then + if (CS%FrictWork_bug) 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 * ( & + 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) * & @@ -1825,7 +1864,38 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + 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 + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork_GME(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx_GME(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx_GME(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy_GME(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy_GME(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy_GME(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy_GME(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + + enddo ; enddo ; endif + endif ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any @@ -2298,6 +2368,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, & + "If true, retain an answer-changing bug in calculating "//& + "the FrictWork, which cancels the h in thickness flux and the h at velocity point. This is"//& + "not recommended.", default=.true.) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& From 935135304a79d86dfcc80fde928355f8c6519d76 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 3 Jun 2024 19:40:52 -0400 Subject: [PATCH 024/128] CI: parse_perf.py bugfix Bracket counter for <..> was correct but (..) was broken, it was counting ( but not ). I can only presume that such cases were very rare. This patch fixes the closed parenthesis count. --- .testing/tools/parse_perf.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index 76c6be5bcb..efcfa13b4f 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -102,7 +102,7 @@ def parse_perf_report(perf_data_path): if tok == '>': bracks -= 1 - if tok == '(': + if tok == ')': parens -= 1 # Strip any whitespace tokens From 10f431239d89216528fb8cec78295ac831fb099c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 12 Mar 2024 12:37:59 -0400 Subject: [PATCH 025/128] Cleaned up MOM_remapping to reduce compiler warnings - Addressed compiler warnings about unused variables and argument intent. - Note there is one dummy argument that was unused and the best way to address the warnings was to remove the argument, i.e. and API change. This was only in a debugging/utility function so does not impact the rest of the model. - Address warnings about unused/uninitialized variables in MOM_remapping.F90 - Sets values that appear to the compiler to be potentially unset, but always are in practice --- src/ALE/MOM_remapping.F90 | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 0fdf80bf52..997f5dc5f6 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -63,8 +63,6 @@ module MOM_remapping integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method -character(len=40) :: mdl = "MOM_remapping" !< This module's name. - !> Documentation for external callers character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& @@ -181,7 +179,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: iMethod ! An integer indicating the integration method used - integer :: k hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge @@ -190,7 +187,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg 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) 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 ) @@ -233,7 +230,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed hNeglect, hNeglect_edge ) 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) ! This is a temporary step prior to switching to remapping_core_h() do k = 1, n1 @@ -387,15 +384,14 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] ! Local variables integer :: i0, n real :: u_l, u_c, u_r ! Cell averages [A] @@ -942,6 +938,7 @@ subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) k_dest = 0 h_dest_rem = 0. h_src_rem = 0. + uh_src_rem = 0. src_ran_out = .false. do while(.true.) @@ -997,8 +994,8 @@ end subroutine reintegrate_column !! separation dh. real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: u0(:) !< Cell means [A] - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: u0(n0) !< Cell means [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index @@ -1013,6 +1010,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + u_ave = 0. ! Avoids warnings about "potentially unset values"; u_ave is always calculated for legitimate schemes if (xb > xa) then select case ( method ) case ( INTEGRATION_PCM ) @@ -1091,6 +1089,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x + xa * ( ppoly0_coefs(i0,4) & + xa * ppoly0_coefs(i0,5) ) ) ) case default + u_ave = 0. call MOM_error( FATAL,'The selected integration method is invalid' ) end select endif From b4e3c64b4df7caa1b676559b07725095f385a119 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 22 Mar 2024 14:23:26 -0400 Subject: [PATCH 026/128] Add timings_tests/time_MOM_remapping - Added new driver, time_MOM_remapping, to config_src/timing_tests/ that exercises the remapping_core_h() function with PCM and PLM. - We should add other reconstruction schemes too, but the main reason for adding this now is to monitor the impact of refactoring the function remapping_core_h() which is mostly independent of the reconstruction schemes. - Fixed .testing/Makefile to not fail with `make build.timing -j` --- .testing/Makefile | 2 + .../timing_tests/time_MOM_remapping.F90 | 100 ++++++++++++++++++ 2 files changed, 102 insertions(+) create mode 100644 config_src/drivers/timing_tests/time_MOM_remapping.F90 diff --git a/.testing/Makefile b/.testing/Makefile index f5da44342d..83dd7dc478 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -265,10 +265,12 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Build executables +.NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) +.NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) $(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 new file mode 100644 index 0000000000..5f4c0258ca --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -0,0 +1,100 @@ +program time_MOM_remapping + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_remapping, only : remapping_CS +use MOM_remapping, only : initialize_remapping +use MOM_remapping, only : remapping_core_h + +implicit none + +type(remapping_CS) :: CS +integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 2 +character(len=10) :: scheme_labels(nschemes) +real, dimension(nschemes) :: timings ! Time for nits of nij calls for each scheme [s] +real, dimension(nschemes) :: tmean ! Mean time for a call [s] +real, dimension(nschemes) :: tstd ! Standard deviation of time for a call [s] +real, dimension(nschemes) :: tmin ! Shortest time for a call [s] +real, dimension(nschemes) :: tmax ! Longest time for a call [s] +real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] +real :: start, finish ! Times [s] +real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] +integer :: ij, k, isamp, iter, ischeme ! Indices and counters +integer :: seed_size ! Number of integers used by seed +integer, allocatable :: seed(:) ! Random number seed + +! Set seed for random numbers +call random_seed(size=seed_size) +allocate( seed(seed_Size) ) +seed(:) = 102030405 +call random_seed(put=seed) + +scheme_labels(1) = 'PCM' +scheme_labels(2) = 'PLM' + +! Set up some test data (note: using k,i indexing rather than i,k) +allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) +call random_number(u0) ! In range 0-1 +call random_number(h0) ! In range 0-1 +call random_number(h1) ! In range 0-1 +do ij = 1, nij + h0(:,ij) = max(0., h0(:,ij) - 0.05) ! Make 5% of values equal to zero + h1(:,ij) = max(0., h1(:,ij) - 0.05) ! Make 5% of values equal to zero + h0sum = h0(1,ij) + h1sum = h1(1,ij) + do k = 2, nk + h0sum = h0sum + h0(k,ij) + h1sum = h1sum + h1(k,ij) + enddo + h0(:,ij) = h0(:,ij) / h0sum + h1(:,ij) = h1(:,ij) / h1sum +enddo + +! Loop over many samples of timing loop to collect statistics +tmean(:) = 0. +tstd(:) = 0. +tmin(:) = 1.e9 +tmax(:) = 0. +do isamp = 1, nsamp + ! Time reconstruction + remapping + do ischeme = 1, nschemes + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme))) + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() + call remapping_core_h(CS, nk, h0(:,ij), u0(:,ij), nk, h1(:,ij), u1(:,ij)) + enddo + enddo + call cpu_time(finish) + timings(ischeme) = (finish-start)/real(nits*nij) ! Average time per call + enddo + tmean(:) = tmean(:) + timings(:) + tstd(:) = tstd(:) + timings(:)**2 ! tstd contains sum of squares here + tmin(:) = min( tmin(:), timings(:) ) + tmax(:) = max( tmax(:), timings(:) ) +enddo +tmean(:) = tmean(:) / real(nsamp) ! convert to mean +tstd(:) = tstd(:) / real(nsamp) ! convert to mean of squares +tstd(:) = tstd(:) - tmean(:)**2 ! convert to variance +tstd(:) = sqrt( tstd(:) * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + + +! Display results in YAML +write(*,'(a)') "{" +do ischeme = 1, nschemes + write(*,"(2x,5a)") '"MOM_remapping remapping_core_h(remapping_scheme=', & + trim(scheme_labels(ischeme)), ')": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(ischeme) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (ischeme.ne.nschemes) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(ischeme) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(ischeme) + endif +enddo +write(*,'(a)') "}" + +end program time_MOM_remapping From a8105af75bc97cc62681a52f57eb7bf821a56cc2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Mar 2024 17:46:42 -0400 Subject: [PATCH 027/128] Added drivers/unit_tests/test_MOM_remapping.F90 Added a simple driver for the remapping unit tests. --- config_src/drivers/unit_tests/test_MOM_remapping.F90 | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 config_src/drivers/unit_tests/test_MOM_remapping.F90 diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 new file mode 100644 index 0000000000..e62b779bd6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -0,0 +1,7 @@ +program test_MOM_remapping + +use MOM_remapping, only : remapping_unit_tests + +if (remapping_unit_tests(.true.)) stop 1 + +end program test_MOM_remapping From 622651bff76ebe26b8c4e6e2a6433bb152375fe0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Mar 2024 22:33:26 -0400 Subject: [PATCH 028/128] Re-factored remapping_unit_tests() - Added a simple class within MOM_remapping.F90 to greatly abbreviate the lines comparing values of arrays. - Translated the existing remapping unit tests to use the testing class. --- src/ALE/MOM_remapping.F90 | 629 +++++++++++++++++++------------------- 1 file changed, 310 insertions(+), 319 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 997f5dc5f6..bb6ec54849 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -40,6 +40,37 @@ module MOM_remapping integer :: answer_date = 99991231 end type +!> Class to assist in unit tests +type :: testing + private + !> True if any fail has been encountered since instantiation of "testing" + logical :: state = .false. + !> Count of tests checked + integer :: num_tests_checked = 0 + !> Count of tests failed + integer :: num_tests_failed = 0 + !> If true, be verbose and write results to stdout. Default True. + logical :: verbose = .true. + !> Error channel + integer :: stderr = 0 + !> Standard output channel + integer :: stdout = 6 + !> If true, stop instantly + logical :: stop_instantly = .false. + !> Record instances that fail + integer :: ifailed(100) = 0. + !> Record label of first instance that failed + character(len=:), allocatable :: label_first_fail + + contains + procedure :: test => test !< Update the testing state + procedure :: set => set !< Set attributes + procedure :: outcome => outcome !< Return current outcome + procedure :: summarize => summarize !< Summarize testing state + procedure :: real_arr => real_arr !< Compare array of reals + procedure :: int_arr => int_arr !< Compare array of integers +end type + ! The following routines are visible to the outside world public remapping_core_h, remapping_core_w public initialize_remapping, end_remapping, remapping_set_param, extract_member_remapping_CS @@ -139,21 +170,6 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex end subroutine extract_member_remapping_CS -!> Calculate edge coordinate x from cell width h -subroutine buildGridFromH(nz, h, x) - integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths [H] - real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] - ! Local variables - integer :: k - - x(1) = 0.0 - do k = 1,nz - x(k+1) = x(k) + h(k) - enddo - -end subroutine buildGridFromH - !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure @@ -1338,74 +1354,60 @@ end subroutine end_remapping logical function remapping_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables - integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1), u0(n0) ! Thicknesses [H], interface heights [H] and values [A] for profile 0 - real :: h1(n1), x1(n1+1), u1(n1) ! Thicknesses [H], interface heights [H] and values [A] for profile 1 - real :: dx1(n1+1) ! Interface height changes for profile 1 [H] - real :: h2(n2), x2(n2+1), u2(n2) ! Thicknesses [H], interface heights [H] and values [A] for profile 2 - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom [A] - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 [H] - data h1 /3*1./ ! 3 uniform layers with total depth of 3 [H] - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 [H] + integer :: n0, n1, n2 + real, allocatable :: h0(:), h1(:), h2(:) ! Thicknesses for test columns [H] + real, allocatable :: u0(:), u1(:), u2(:) ! Values for test profiles [A] + real, allocatable :: dx1(:) ! Change in interface position [H] type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] integer :: answer_date ! The vintage of the expressions to test - integer :: i real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be ! added to thicknesses in a denominator without ! changing the numerical result, except where ! a division by zero would otherwise occur. real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] - logical :: thisTest, v, fail + type(testing) :: test ! Unit testing convenience functions + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test - v = verbose answer_date = 20190101 ! 20181231 h_neglect = hNeglect_dflt h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' - remapping_unit_tests = .false. ! Normally return false + if (verbose) write(stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' - thisTest = .false. - call buildGridFromH(n0, h0, x0) - do i=1,n0+1 - err=x0(i)-0.75*real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest - call buildGridFromH(n1, h1, x1) - do i=1,n1+1 - err=x1(i)-real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest + ! This line carries out tests on some older remapping schemes. + call test%test( remapping_attic_unit_tests(verbose), 'attic remapping unit tests' ) + + if (verbose) write(stdout,*) ' - - - - - 1st generation tests - - - - -' - thisTest = .false. call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) + ! Profile 0: 4 layers of thickness 0.75 and total depth 3, with du/dz=8 + n0 = 4 + allocate( h0(n0), u0(n0) ) + h0 = (/0.75, 0.75, 0.75, 0.75/) + u0 = (/9., 3., -3., -9./) + + ! Profile 1: 3 layers of thickness 1.0 and total depth 3 + n1 = 3 + allocate( h1(n1), u1(n1), dx1(n1+1) ) + h1 = (/1.0, 1.0, 1.0/) + + ! Profile 2: 6 layers of thickness 0.5 and total depth 3 + n2 = 6 + allocate( h2(n2), u2(n2) ) + h2 = (/0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) + + ! Mapping u1 from h1 to h2 call dzFromH1H2( n0, h0, n1, h1, dx1 ) call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. - enddo - if (verbose) write(stdout,*) 'h1 (by projection)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,CS%degree+1)) + call test%real_arr(3, u1, (/8.,0.,-8./), 'remapping_core_w() PPM_H4') + allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 @@ -1414,387 +1416,376 @@ logical function remapping_unit_tests(verbose) call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) - thisTest = .false. - call buildGridFromH(n2, h2, x2) - - if (verbose) write(stdout,*) 'Via sub-cells' - thisTest = .false. call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(n2,h2,x2,u2) - - do i=1,n2 - err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remap_via_sub_cells() 2') call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(6,h2,x2,u2) + call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remap_via_sub_cells() 3') call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(3,h2,x2,u2) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') - write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' + if (verbose) write(stdout,*) ' - - - - - reconstruction tests - - - - -' deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) allocate(ppoly0_coefs(5,6)) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & - h_neglect=1e-10, answer_date=answer_date ) + call PCM_reconstruction(3, (/1.,2.,4./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:) ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), & + ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + call test%real_arr(5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + call test%real_arr(5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10, answer_date=answer_date ) ! The next two tests are now passing when answer_date >= 20190101, but otherwise only work to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + call test%real_arr(5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + call test%real_arr(5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & ppoly0_coefs(1:4,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + call test%real_arr(4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & ppoly0_coefs(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - ! This line carries out tests on some older remapping schemes. - remapping_unit_tests = remapping_unit_tests .or. remapping_attic_unit_tests(verbose) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' - - write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' - if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + if (verbose) write(stdout,*) ' - - - - - interpolation tests - - - - -' - fail = test_interp(verbose, 'Identity: 3 layer', & + call test_interp(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'A: 3 layer to 2', & + call test_interp(test, 'A: 3 layer to 2', & 3, (/1.,1.,1./), (/1.,2.,3.,4./), & 2, (/1.5,1.5/), (/1.,2.5,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'B: 2 layer to 3', & + call test_interp(test, 'B: 2 layer to 3', & 2, (/1.5,1.5/), (/1.,4.,7./), & 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'C: 3 layer (vanished middle) to 2', & + call test_interp(test, 'C: 3 layer (vanished middle) to 2', & 3, (/1.,0.,2./), (/1.,2.,2.,3./), & 2, (/1.,2./), (/1.,2.,3./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'D: 3 layer (deep) to 3', & + call test_interp(test, 'D: 3 layer (deep) to 3', & 3, (/1.,2.,3./), (/1.,2.,4.,7./), & 2, (/2.,2./), (/1.,3.,5./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'E: 3 layer to 3 (deep)', & + call test_interp(test, 'E: 3 layer to 3 (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'F: 3 layer to 4 with vanished top/botton', & + call test_interp(test, 'F: 3 layer to 4 with vanished top/botton', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + call test_interp(test, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & + call test_interp(test, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (verbose) write(stdout,*) ' - - - - - reintegration tests - - - - -' - fail = test_reintegrate(verbose, 'Identity: 3 layer', & + call test_reintegrate(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & 3, (/1.,2.,3./), (/-5.,2.,1./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2', & + call test_reintegrate(test, 'A: 3 layer to 2', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,3./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (deep)', & + call test_reintegrate(test, 'A: 3 layer to 2 (deep)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,4./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (shallow)', & + call test_reintegrate(test, 'A: 3 layer to 2 (shallow)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,2./), (/-4.,1.5/) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'B: 3 layer to 4 with vanished top/bottom', & + call test_reintegrate(test, 'B: 3 layer to 4 with vanished top/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'C: 3 layer to 4 with vanished top//middle/bottom', & + call test_reintegrate(test, 'C: 3 layer to 4 with vanished top//middle/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer to 3 (vanished)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3', & 3, (/0.,0.,0./), (/-5.,2.,1./), & 3, (/2.,2.,2./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + remapping_unit_tests = test%summarize('remapping_unit_tests') end function remapping_unit_tests -!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label, tol) - logical, intent(in) :: verbose !< If true, write results to stdout +!> Test if interpolate_column() produces the wrong answer +subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + call test%real_arr(ndest, u_dest, u_true, msg) +end subroutine test_interp + +!> Test if reintegrate_column() produces the wrong answer +subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + call test%real_arr(ndest, uh_dest, uh_true, msg) + +end subroutine test_reintegrate + +! ========================================================================================= +! The following provide the function for the testing_type helper class + +!> Update the state with "test" +subroutine test(this, state, label) + class(testing), intent(inout) :: this !< This testing class + logical, intent(in) :: state !< True to indicate a fail, false otherwise + character(len=*), intent(in) :: label !< Message + + this%num_tests_checked = this%num_tests_checked + 1 + if (state) then + this%state = .true. + this%num_tests_failed = this%num_tests_failed + 1 + this%ifailed( this%num_tests_failed ) = this%num_tests_checked + if (this%num_tests_failed == 1) this%label_first_fail = label + endif + if (this%stop_instantly .and. this%state) stop 1 +end subroutine test + +!> Set attributes +subroutine set(this, verbose, stdout, stderr, stop_instantly) + class(testing), intent(inout) :: this !< This testing class + logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity + integer, optional, intent(in) :: stdout !< The stdout channel to use + integer, optional, intent(in) :: stderr !< The stderr channel to use + logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection + + if (present(verbose)) then + this%verbose = verbose + endif + if (present(stdout)) then + this%stdout = stdout + endif + if (present(stderr)) then + this%stderr = stderr + endif + if (present(stop_instantly)) then + this%stop_instantly = stop_instantly + endif +end subroutine set + +!> Returns state +logical function outcome(this) + class(testing), intent(inout) :: this !< This testing class + outcome = this%state +end function outcome + +!> Summarize results +logical function summarize(this, label) + class(testing), intent(inout) :: this !< This testing class + character(len=*), intent(in) :: label !< Message + integer :: i + + if (this%state) then + write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & + 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked + write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) + write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) + write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a," : ",a)') trim(label),'FAILED' + else + write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & + 'Pass', trim(label), this%num_tests_checked + endif + summarize = this%state +end function summarize + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_arr(this, n, u_test, u_true, label, tol) + class(testing), intent(inout) :: this !< This testing class integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test [A] + real, dimension(n), intent(in) :: u_test !< Values to test [A] real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] character(len=*), intent(in) :: label !< Message real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] ! Local variables - real :: tolerance ! The tolerance for differences between u and u_true [A] integer :: k + logical :: this_test + real :: tolerance, err ! Tolerance for differences, and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + this_test = .false. - tolerance = 0.0 ; if (present(tol)) tolerance = tol - test_answer = .false. + ! Scan for any mismatch between u_test and u_true do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. + if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. enddo - if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + + ! If either being verbose, or an error was measured then display results + if (this_test .or. this%verbose) then + write(this%stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + if (this_test) write(this%stderr,'(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' - write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + err = u_test(k) - u_true(k) + if (abs(err) > tolerance) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' else - write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) + write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) endif enddo endif -end function test_answer - -!> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine real_arr + +!> Compare i_test to i_true and report and return true if a difference is found +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine int_arr(this, n, i_test, i_true, label) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + integer, dimension(n), intent(in) :: i_test !< Values to test [A] + integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message ! Local variables - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] integer :: k - real :: error ! The difference between the evaluated and expected solutions [A] + logical :: this_test - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + this_test = .false. - test_interp = .false. - do k=1,ndest+1 - if (u_dest(k)/=u_true(k)) test_interp = .true. + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (i_test(k) .ne. i_true(k)) this_test = .true. enddo - if (verbose .or. test_interp) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' - do k=1,ndest+1 - error = u_dest(k)-u_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_interp - -!> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] - integer :: k - real :: error ! The difference between the evaluated and expected solutions [A H] - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) - - test_reintegrate = .false. - do k=1,ndest - if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. - enddo - if (verbose .or. test_reintegrate) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' - do k=1,ndest - error = uh_dest(k)-uh_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_reintegrate - -!> Convenience function for printing grid to screen -subroutine dumpGrid(n,h,x,u) - integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness [H] - real, dimension(:), intent(in) :: x !< Interface delta [H] - real, dimension(:), intent(in) :: u !< Cell average values [A] - integer :: i - write(stdout,'("i=",20i10)') (i,i=1,n+1) - write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) - write(stdout,'("i=",5x,20i10)') (i,i=1,n) - write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) -end subroutine dumpGrid + if (this%verbose) then + write(this%stdout,'(a12," : calculated =",30i3)') label, i_test + write(this%stdout,'(12x," correct =",30i3)') i_true + if (this_test) write(this%stdout,'(3x,a,8x,"error =",30i3)') 'FAIL --->', i_test(:) - i_true(:) + endif + if (this_test) then + write(this%stderr,'(a12," : calculated =",30i3)') label, i_test + write(this%stderr,'(12x," correct =",30i3)') i_true + write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) + endif + + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine int_arr end module MOM_remapping From b2629554c32ea8d438e567c23aeec267d99fd9c6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 12 Mar 2024 14:52:16 -0400 Subject: [PATCH 029/128] Refactor/split remap_via_sub_cells() adding intersect_src_tgt_grids() - The first block of remap_via_sub_cells() computes the intersection between two columns (grids). I've split out this block into a stand alone function so that we can re-use it in a to-be-written analog of remap_via_sub_cells() that will remap integrated quantities. - Added some in-line documentation of algorithm used by remap_via_sub_cells() - Added new column-wise function intersect_src_tgt_grids() - Added tests of intersect_src_tgt_grids() that check against known results - Had to add a new helper function to MOM_remapping to report state of integer arrays. --- src/ALE/MOM_remapping.F90 | 509 ++++++++++++++++++++++++++++---------- 1 file changed, 377 insertions(+), 132 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index bb6ec54849..09ef896014 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -493,8 +493,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer :: i_sub ! Index of sub-cell integer :: i0 ! Index into h0(1:n0), source column integer :: i1 ! Index into h1(1:n1), target column - integer :: i_start0 ! Used to record which sub-cells map to source cells - integer :: i_start1 ! Used to record which sub-cells map to target cells integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] @@ -510,7 +508,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] - real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] real :: dh ! The width of the sub-cell [H] real :: duh ! The total amount of accumulated stuff (u*h) [A H] real :: dh0_eff ! Running sum of source cell thickness [H] @@ -525,8 +522,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] real :: u_orig ! The original value of the reconstruction in a cell [A] real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] - logical :: src_has_volume !< True if h0 has not been consumed - logical :: tgt_has_volume !< True if h1 has not been consumed i0_last_thick_cell = 0 do i0 = 1, n0 @@ -535,134 +530,13 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth if (h0(i0)>0.) i0_last_thick_cell = i0 enddo - ! Initialize algorithm - h0_supply = h0(1) - h1_supply = h1(1) - src_has_volume = .true. - tgt_has_volume = .true. - i0 = 1 ; i1 = 1 - i_start0 = 1 ; i_start1 = 1 - i_max = 1 - dh_max = 0. - dh0_eff = 0. - - ! First sub-cell is always vanished - h_sub(1) = 0. - isrc_start(1) = 1 - isrc_end(1) = 1 - isrc_max(1) = 1 - isub_src(1) = 1 - - ! Loop over each sub-cell to calculate intersections with source and target grids - do i_sub = 2, n0+n1+1 - - ! This is the width of the sub-cell, determined by which ever column has the least - ! supply available to consume. - dh = min(h0_supply, h1_supply) - - ! This is the running sum of the source cell thickness. After summing over each - ! sub-cell, the sum of sub-cell thickness might differ from the original source - ! cell thickness due to round off. - dh0_eff = dh0_eff + min(dh, h0_supply) - - ! Record the source index (i0) that this sub-cell integral belongs to. This - ! is needed to index the reconstruction coefficients for the source cell - ! used in the integrals of the sub-cell width. - isub_src(i_sub) = i0 - h_sub(i_sub) = dh - - ! For recording the largest sub-cell within a source cell. - if (dh >= dh_max) then - i_max = i_sub - dh_max = dh - endif - - ! Which ever column (source or target) has the least width left to consume determined - ! the width, dh, of sub-cell i_sub in the expression for dh above. - if (h0_supply <= h1_supply .and. src_has_volume) then - ! h0_supply is smaller than h1_supply) so we consume h0_supply and increment the - ! source cell index. - h1_supply = h1_supply - dh ! Although this is a difference the result will - ! be non-negative because of the conditional. - ! Record the sub-cell start/end index that span the source cell i0. - isrc_start(i0) = i_start0 - isrc_end(i0) = i_sub - i_start0 = i_sub + 1 - ! Record the sub-cell that is the largest fraction of the source cell. - isrc_max(i0) = i_max - i_max = i_sub + 1 - dh_max = 0. - ! Record the source cell thickness found by summing the sub-cell thicknesses. - h0_eff(i0) = dh0_eff - ! Move the source index. - if (i0 < n0) then - i0 = i0 + 1 - h0_supply = h0(i0) - dh0_eff = 0. - else - h0_supply = 0. - src_has_volume = .false. - endif - elseif (h0_supply >= h1_supply .and. tgt_has_volume) then - ! h1_supply is smaller than h0_supply) so we consume h1_supply and increment the - ! target cell index. - h0_supply = h0_supply - dh ! Although this is a difference the result will - ! be non-negative because of the conditional. - ! Record the sub-cell start/end index that span the target cell i1. - itgt_start(i1) = i_start1 - itgt_end(i1) = i_sub - i_start1 = i_sub + 1 - ! Move the target index. - if (i1 < n1) then - i1 = i1 + 1 - h1_supply = h1(i1) - else - h1_supply = 0. - tgt_has_volume = .false. - endif - elseif (src_has_volume) then - ! We ran out of target volume but still have source cells to consume - h_sub(i_sub) = h0_supply - ! Record the sub-cell start/end index that span the source cell i0. - isrc_start(i0) = i_start0 - isrc_end(i0) = i_sub - i_start0 = i_sub + 1 - ! Record the sub-cell that is the largest fraction of the source cell. - isrc_max(i0) = i_max - i_max = i_sub + 1 - dh_max = 0. - ! Record the source cell thickness found by summing the sub-cell thicknesses. - h0_eff(i0) = dh0_eff - if (i0 < n0) then - i0 = i0 + 1 - h0_supply = h0(i0) - dh0_eff = 0. - else - h0_supply = 0. - src_has_volume = .false. - endif - elseif (tgt_has_volume) then - ! We ran out of source volume but still have target cells to consume - h_sub(i_sub) = h1_supply - ! Record the sub-cell start/end index that span the target cell i1. - itgt_start(i1) = i_start1 - itgt_end(i1) = i_sub - i_start1 = i_sub + 1 - ! Move the target index. - if (i1 < n1) then - i1 = i1 + 1 - h1_supply = h1(i1) - else - h1_supply = 0. - tgt_has_volume = .false. - endif - else - stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' - endif - - enddo + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub xa = 0. dh0_eff = 0. uh_sub(1) = 0. @@ -728,6 +602,8 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub do i0 = 1, i0_last_thick_cell i_max = isrc_max(i0) dh_max = h_sub(i_max) @@ -744,6 +620,8 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1 uh_err = 0. do i1 = 1, n1 if (h1(i1) > 0.) then @@ -863,6 +741,190 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth end subroutine remap_via_sub_cells +!> Returns the intersection of source and targets grids along with and auxiliary lists or indices. +!! +!! For source grid with thicknesses h0(1:n0) and target grid with thicknesses h1(1:n1) the intersection +!! or "subgrid" has thicknesses h_sub(1:n0+n1+1). +!! h0 and h1 must have the same units. h_sub will return with the same units as h0 and h1. +!! +!! Notes on the algorithm: +!! Internally, grids are defined by the interfaces (although we describe grids via thicknesses for accuracy). +!! The intersection or union of two grids is thus defined by the super set of both lists of interfaces. +!! Because both source and target grids can contain vanished cells, we do not eliminate repeated +!! interfaces from the union. +!! That is, the total number of interfaces of the sub-cells is equal to the total numer of interfaces of +!! the source grid (n0+1) plus the total number of interfaces of the target grid (n1+1), i.e. n0+n1+2. +!! Whenever target and source interfaces align, then the retention of identical interfaces leads to a +!! vanished subcell. +!! The remapping uses a common point of reference to the left (top) so there is always a vanished subcell +!! at the left (top). +!! If the total column thicknesses are the same, then the right (bottom) interfaces are also aligned and +!! so the last subcell will also be vanished. +subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(out) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(out) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(out) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(out) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(out) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(out) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(out) :: itgt_end(n1) !< Index of last sub-cell within each target cell + integer, intent(out) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i1 ! Index into h1(1:n1), target column + integer :: i_start0 ! Used to record which sub-cells map to source cells + integer :: i_start1 ! Used to record which sub-cells map to target cells + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] + real :: dh ! The width of the sub-cell [H] + real :: dh0_eff ! Running sum of source cell thickness [H] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. + integer :: i0_last_thick_cell + logical :: src_has_volume !< True if h0 has not been consumed + logical :: tgt_has_volume !< True if h1 has not been consumed + + i0_last_thick_cell = 0 + do i0 = 1, n0 + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Initialize algorithm + h0_supply = h0(1) + h1_supply = h1(1) + src_has_volume = .true. + tgt_has_volume = .true. + i0 = 1 ; i1 = 1 + i_start0 = 1 ; i_start1 = 1 + i_max = 1 + dh_max = 0. + dh0_eff = 0. + + ! First sub-cell is always vanished + h_sub(1) = 0. + isrc_start(1) = 1 + isrc_end(1) = 1 + isrc_max(1) = 1 + isub_src(1) = 1 + + ! Loop over each sub-cell to calculate intersections with source and target grids + do i_sub = 2, n0+n1+1 + + ! This is the width of the sub-cell, determined by which ever column has the least + ! supply available to consume. + dh = min(h0_supply, h1_supply) + + ! This is the running sum of the source cell thickness. After summing over each + ! sub-cell, the sum of sub-cell thickness might differ from the original source + ! cell thickness due to round off. + dh0_eff = dh0_eff + min(dh, h0_supply) + + ! Record the source index (i0) that this sub-cell integral belongs to. This + ! is needed to index the reconstruction coefficients for the source cell + ! used in the integrals of the sub-cell width. + isub_src(i_sub) = i0 + h_sub(i_sub) = dh + + ! For recording the largest sub-cell within a source cell. + if (dh >= dh_max) then + i_max = i_sub + dh_max = dh + endif + + ! Which ever column (source or target) has the least width left to consume determined + ! the width, dh, of sub-cell i_sub in the expression for dh above. + if (h0_supply <= h1_supply .and. src_has_volume) then + ! h0_supply is smaller than h1_supply) so we consume h0_supply and increment the + ! source cell index. + h1_supply = h1_supply - dh ! Although this is a difference the result will + ! be non-negative because of the conditional. + ! Record the sub-cell start/end index that span the source cell i0. + isrc_start(i0) = i_start0 + isrc_end(i0) = i_sub + i_start0 = i_sub + 1 + ! Record the sub-cell that is the largest fraction of the source cell. + isrc_max(i0) = i_max + i_max = i_sub + 1 + dh_max = 0. + ! Record the source cell thickness found by summing the sub-cell thicknesses. + h0_eff(i0) = dh0_eff + ! Move the source index. + if (i0 < n0) then + i0 = i0 + 1 + h0_supply = h0(i0) + dh0_eff = 0. + else + h0_supply = 0. + src_has_volume = .false. + endif + elseif (h0_supply >= h1_supply .and. tgt_has_volume) then + ! h1_supply is smaller than h0_supply) so we consume h1_supply and increment the + ! target cell index. + h0_supply = h0_supply - dh ! Although this is a difference the result will + ! be non-negative because of the conditional. + ! Record the sub-cell start/end index that span the target cell i1. + itgt_start(i1) = i_start1 + itgt_end(i1) = i_sub + i_start1 = i_sub + 1 + ! Move the target index. + if (i1 < n1) then + i1 = i1 + 1 + h1_supply = h1(i1) + else + h1_supply = 0. + tgt_has_volume = .false. + endif + elseif (src_has_volume) then + ! We ran out of target volume but still have source cells to consume + h_sub(i_sub) = h0_supply + ! Record the sub-cell start/end index that span the source cell i0. + isrc_start(i0) = i_start0 + isrc_end(i0) = i_sub + i_start0 = i_sub + 1 + ! Record the sub-cell that is the largest fraction of the source cell. + isrc_max(i0) = i_max + i_max = i_sub + 1 + dh_max = 0. + ! Record the source cell thickness found by summing the sub-cell thicknesses. + h0_eff(i0) = dh0_eff + if (i0 < n0) then + i0 = i0 + 1 + h0_supply = h0(i0) + dh0_eff = 0. + else + h0_supply = 0. + src_has_volume = .false. + endif + elseif (tgt_has_volume) then + ! We ran out of source volume but still have target cells to consume + h_sub(i_sub) = h1_supply + ! Record the sub-cell start/end index that span the target cell i1. + itgt_start(i1) = i_start1 + itgt_end(i1) = i_sub + i_start1 = i_sub + 1 + ! Move the target index. + if (i1 < n1) then + i1 = i1 + 1 + h1_supply = h1(i1) + else + h1_supply = 0. + tgt_has_volume = .false. + endif + else + stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' + endif + + enddo +end subroutine intersect_src_tgt_grids + !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) integer, intent(in) :: nsrc !< Number of source cells @@ -1362,6 +1424,8 @@ logical function remapping_unit_tests(verbose) real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] + real, allocatable, dimension(:) :: h_sub, h0_eff ! Subgrid and effective source thicknesses [H] + integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices integer :: answer_date ! The vintage of the expressions to test real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be ! added to thicknesses in a denominator without @@ -1428,9 +1492,13 @@ logical function remapping_unit_tests(verbose) 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + + ! =============================================== + ! This section tests the reconstruction functions + ! =============================================== if (verbose) write(stdout,*) ' - - - - - reconstruction tests - - - - -' - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) allocate(ppoly0_coefs(5,6)) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) @@ -1508,6 +1576,10 @@ logical function remapping_unit_tests(verbose) call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + ! ============================================================== + ! This section tests the components of remapping_via_sub_cells() + ! ============================================================== + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & ppoly0_coefs(1:4,:), h_neglect ) call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') @@ -1521,6 +1593,179 @@ logical function remapping_unit_tests(verbose) if (verbose) write(stdout,*) ' - - - - - interpolation tests - - - - -' + ! Test 1: n0=2, n1=3 Maps uniform grids with one extra target layer and no implicitly-vanished interior sub-layers + ! h_src = | 3 | 3 | + ! h_tgt = | 2 | 2 | 2 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 4 | + ! isrc_end | 3 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 3 | 5 | + ! itgt_end | 2 | 4 | 6| + ! isub_src |1| 1 | 1 | 2 | 2 |2| + allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 2, (/3., 3./), & ! n0, h0 + 3, (/2., 2., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" + if (verbose) write(stdout,*) " h_src = | 3 | 3 |" + if (verbose) write(stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/3.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,4/), 'isrc_start') + call test%int_arr(2, isrc_end, (/3,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,3,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/2,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,1,2,2,2/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 2: n0=3, n1=2 Reverses "test 1" with more source than target layers + ! h_src = | 2 | 2 | 2 | + ! h_tgt = | 3 | 3 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3 | 6| + ! isub_src |1| 1 | 2 | 2 | 3 |3| + allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(2), itgt_end(2), isub_src(6) ) + call intersect_src_tgt_grids( 3, (/2., 2., 2./), & ! n0, h0 + 2, (/3., 3./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" + if (verbose) write(stdout,*) " h_src = | 2 | 2 | 2 |" + if (verbose) write(stdout,*) " h_tgt = | 3 | 3 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 3: n0=2, n1=3 With aligned interfaces that lead to implicitly-vanished interior sub-layers + ! h_src = | 2 | 4 | + ! h_tgt = | 2 | 2 | 2 | + ! h_sub = |0| 2 |0| 2 | 2 |0| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 6| + ! isub_src |1| 1 |2| 2 | 2 |2| + allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 2, (/2., 4./), & ! n0, h0 + 3, (/2., 2., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" + if (verbose) write(stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,4./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)sum(h_src), useful for diagnostics + ! h_src = | 2 | 2 | 1 | + ! h_tgt = | 2 | 4 | + ! h_sub = |0| 2 |0| 2 | 1 | 1 | + ! isrc_start |1 |3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | | + ! itgt_start |1 | 4 | + ! itgt_end | 3| 6 | + ! isub_src |1| 1 |2| 2 | 3 | 3 | + allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 3, (/2., 2., 1./), & ! n0, h0 + 2, (/2., 4./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" + if (verbose) write(stdout,*) " h_src = | 2 | 2 | 1 |" + if (verbose) write(stdout,*) " h_tgt = | 2 | 4 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,1./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 6: n0=3, n1=5 Source and targets with vanished layers + ! h_src = | 2 |0| 2 | + ! h_tgt = | 1 |0| 1 |0| 2 | + ! h_sub = |0| 1 |0| 1 |0|0|0| 2 |0| + ! isrc_start |1 |5|6 | + ! isrc_end | 4 |5| 8 | + ! isrc_max | 4 |5| 8 | + ! itgt_start |1 |3| 4 |7| 8 | + ! itgt_end | 2 |3| 6|7| 9| + ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| + allocate( h_sub(9), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(5), itgt_end(5), isub_src(9) ) + call intersect_src_tgt_grids( 3, (/2., 0., 2./), & ! n0, h0 + 5, (/1., 0., 1., 0., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" + if (verbose) write(stdout,*) " h_src = | 2 |0| 2 |" + if (verbose) write(stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" + call test%real_arr(9, h_sub, (/0.,1.,0.,1.,0.,0.,0.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,0.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,5,6/), 'isrc_start') + call test%int_arr(3, isrc_end, (/4,5,8/), 'isrc_end') + call test%int_arr(3, isrc_max, (/4,5,8/), 'isrc_max') + call test%int_arr(5, itgt_start, (/1,3,4,7,8/), 'itgt_start') + call test%int_arr(5, itgt_end, (/2,3,6,7,9/), 'itgt_end') + call test%int_arr(9, isub_src, (/1,1,1,1,2,3,3,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! ============================================================ + ! This section tests interpolation and reintegration functions + ! ============================================================ + if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + call test_interp(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) From 11c50db7bf0a20424eabd13fe2d1f1d0216ee4c2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 12 Mar 2024 14:52:16 -0400 Subject: [PATCH 030/128] Refactor/split remap_via_sub_cells() adding remap_src_to_sub_grid() - This second phase of remap_via_sub_cells() maps the values from the source grid to the sub-grid using the pre-calculated arrays/indices from intersect_src_tgt_grids(). This phase as-is is only used for remapping of intensive variables but it does implicitly calculate intermediate extensive quantities which are analogous to what we need when remapping momentum. Splitting this phase out primarily allows us to test this bit of code and it has indeed revealed an edge case that fails. - Added new column-wise function remap_src_to_sub_grid() - Added tests of remap_src_to_sub_grid() that check against known results - One test is commented out corresponding to an edge case that reveals the current code is wrong. Will enable this test after checking how many experiments are impacted but the associated bug fix. --- src/ALE/MOM_remapping.F90 | 264 ++++++++++++++++++++++++++------------ 1 file changed, 180 insertions(+), 84 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 09ef896014..ff50b54f24 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -493,8 +493,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer :: i_sub ! Index of sub-cell integer :: i0 ! Index into h0(1:n0), source column integer :: i1 ! Index into h1(1:n1), target column - integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell - real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] @@ -535,89 +533,11 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Loop over each sub-cell to calculate average/integral values within each sub-cell. - ! Uses: h_sub, isub_src, h0_eff + ! Uses: h_sub, h0_eff, isub_src, h0_eff ! Sets: u_sub, uh_sub - xa = 0. - dh0_eff = 0. - uh_sub(1) = 0. - u_sub(1) = ppoly0_E(1,1) - u02_err = 0. - do i_sub = 2, n0+n1 - - ! Sub-cell thickness from loop above - dh = h_sub(i_sub) - - ! Source cell - i0 = isub_src(i_sub) - - ! Evaluate average and integral for sub-cell i_sub. - ! Integral is over distance dh but expressed in terms of non-dimensional - ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). - dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell - if (h0_eff(i0)>0.) then - xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 - xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) - else ! Vanished cell - xb = 1. - u_sub(i_sub) = u0(i0) - endif - if (debug_bounds) then - if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then - write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method - write(0,*) 'xa,xb: ',xa,xb - write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) - write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) - write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) - write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Sub-cell average is out of bounds!' ) - endif - endif - if (force_bounds_in_subcell) then - ! These next two lines should not be needed but when using PQM we found roundoff - ! can lead to overshoots. These lines sweep issues under the rug which need to be - ! properly .. later. -AJA - u_orig = u_sub(i_sub) - u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) - u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) - u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) - endif - uh_sub(i_sub) = dh * u_sub(i_sub) - - if (isub_src(i_sub+1) /= i0) then - ! If the next sub-cell is in a different source cell, reset the position counters - dh0_eff = 0. - xa = 0. - else - xa = xb ! Next integral will start at end of last - endif - - enddo - u_sub(n0+n1+1) = ppoly0_E(n0,2) ! This value is only needed when total target column - uh_sub(n0+n1+1) = ppoly0_E(n0,2) * h_sub(n0+n1+1) ! is wider than the source column - - if (adjust_thickest_subcell) then - ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within - ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals - ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). - ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 - ! Updates: uh_sub - do i0 = 1, i0_last_thick_cell - i_max = isrc_max(i0) - dh_max = h_sub(i_max) - if (dh_max > 0.) then - ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. - duh = 0. - do i_sub = isrc_start(i0), isrc_end(i0) - if (i_sub /= i_max) duh = duh + uh_sub(i_sub) - enddo - uh_sub(i_max) = u0(i0)*h0(i0) - duh - u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) - endif - enddo - endif + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub @@ -925,6 +845,138 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & enddo end subroutine intersect_src_tgt_grids +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + uh_sub(1) = 0. + u_sub(1) = ppoly0_E(1,1) + u02_err = 0. + do i_sub = 2, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0_eff(i0)>0.) then + xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (debug_bounds) then + if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then + write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method + write(0,*) 'xa,xb: ',xa,xb + write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) + write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) + write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) + write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) + write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) + call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& + 'Sub-cell average is out of bounds!' ) + endif + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + u_sub(n0+n1+1) = ppoly0_E(n0,2) ! This value is only needed when total target column + uh_sub(n0+n1+1) = ppoly0_E(n0,2) * h_sub(n0+n1+1) ! is wider than the source column + + if (adjust_thickest_subcell) then + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + endif + +end subroutine remap_src_to_sub_grid + !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) integer, intent(in) :: nsrc !< Number of source cells @@ -1425,6 +1477,8 @@ logical function remapping_unit_tests(verbose) real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] real, allocatable, dimension(:) :: h_sub, h0_eff ! Subgrid and effective source thicknesses [H] + real, allocatable, dimension(:) :: u_sub, uh_sub ! Subgrid values and totals [A, A H] + real :: u02_err ! Error in remaping [A] integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices integer :: answer_date ! The vintage of the expressions to test real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be @@ -1675,6 +1729,20 @@ logical function remapping_unit_tests(verbose) call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(2,2), ppoly0_E(2,2), ppoly0_S(2,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 6 |7| + call PLM_reconstruction(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(2, (/2.,4./),(/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(6), uh_sub(6)) + call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & + 3, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)|<- 4 ->| +! ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| +! ! u_src = | 2 | 5 | +! ! edge = |1 3|3 7| +! ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | +! call PLM_reconstruction(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect ) +! call PLM_boundary_extrapolation(2, (/2.,4./),(/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect) +! allocate(u_sub(6), uh_sub(6)) +! call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & +! 3, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & +! INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) +! call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') +! deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Test 5: n0=2, n1=3 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics @@ -1731,7 +1813,21 @@ logical function remapping_unit_tests(verbose) call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + allocate(ppoly0_coefs(3,2), ppoly0_E(3,2), ppoly0_S(3,2)) + ! h_src = | 2 | 2 | 1 | + ! h_sub = |0| 2 |0| 2 | 1 | 1 | + ! u_src = | 2 | 4 | 5.5 | + ! edge = |1 3|3 5|5 6| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + call PLM_reconstruction(3, (/2.,2.,1./), (/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(3, (/2.,2.,1./),(/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(6), uh_sub(6)) + call remap_src_to_sub_grid(3, (/2.,2.,1./), (/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, & + 2, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) ! Test 6: n0=3, n1=5 Source and targets with vanished layers ! h_src = | 2 |0| 2 | From 99363e462cdebaadc09c7e976a70912bcde4cd46 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 2 Apr 2024 11:23:07 -0400 Subject: [PATCH 031/128] Removed debugging from remap_via_sub_cells() in MOM_remapping.F90 - We had debugging left over from development a decade ago that was retained "just in case" but has been obsoleted by the unit testing. - Also cleaned up unused variables. --- src/ALE/MOM_remapping.F90 | 112 +------------------------------------- 1 file changed, 2 insertions(+), 110 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index ff50b54f24..a5f470acad 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -491,7 +491,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, optional, intent(out) :: aise(n0) !< isrc_ens ! Local variables integer :: i_sub ! Index of sub-cell - integer :: i0 ! Index into h0(1:n0), source column integer :: i1 ! Index into h1(1:n1), target column real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] @@ -501,32 +500,16 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] - real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell [A] - real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell [A] integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] real :: dh ! The width of the sub-cell [H] real :: duh ! The total amount of accumulated stuff (u*h) [A H] - real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. - integer :: k, i0_last_thick_cell - real :: h0tot, h1tot, h2tot ! Summed thicknesses used for debugging [H] - real :: h0err, h1err, h2err ! Estimates of round-off errors used for debugging [H] - real :: u02_err, u0err, u1err, u2err ! Integrated reconstruction error estimates [H A] - real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] + real :: u02_err ! Integrated reconstruction error estimates [H A] real :: u_orig ! The original value of the reconstruction in a cell [A] - real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] - - i0_last_thick_cell = 0 - do i0 = 1, n0 - u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) - u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) - if (h0(i0)>0.) i0_last_thick_cell = i0 - enddo + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & @@ -575,82 +558,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif enddo - ! Check errors and bounds - if (debug_bounds) then - call measure_input_bounds( n0, h0, u0, ppoly0_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - call measure_output_bounds( n0+n1+1, h_sub, u_sub, h2tot, h2err, u2tot, u2err, u2min, u2max ) - if (method<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err+u02_err .and. abs(h1tot-h0tot)u0err+u2err+u02_err .and. abs(h2tot-h0tot)u0max) ) then - write(0,*) 'method = ',method - write(0,*) 'Source to sub-cells:' - write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) & - write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& - 'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) & - write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' - write(0,*) 'Sub-cells to target:' - write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' - write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) & - write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' - write(0,*) 'Source to target:' - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min - if (u1minu0max) write(0,*) 'U2 maximum overshoot=',u2max-u0max,' <-----!' - write(0,'(a3,6a24,2a3)') 'k','h0','left edge','u0','right edge','h1','u1','is','ie' - do k = 1, max(n0,n1) - if (k<=min(n0,n1)) then - write(0,'(i3,1p6e24.16,2i3)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2),h1(k),u1(k),itgt_start(k),itgt_end(k) - elseif (k>n0) then - write(0,'(i3,96x,1p2e24.16,2i3)') k,h1(k),u1(k),itgt_start(k),itgt_end(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) - enddo - write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' - xa = 0. - dh0_eff = 0. - do k = 1, n0+n1+1 - dh = h_sub(k) - i0 = isub_src(k) - dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell - xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 - xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - write(0,'(i3,1p3e24.16,i3,1p2e24.16)') k,h_sub(k),u_sub(k),uh_sub(k),i0,xa,xb - if (k<=n0+n1) then - if (isub_src(k+1) /= i0) then - dh0_eff = 0.; xa = 0. - else - xa = xb - endif - endif - enddo - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif ! debug_bounds - ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err @@ -707,7 +614,6 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. integer :: i0_last_thick_cell logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed @@ -879,7 +785,6 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, ! For error checking/debugging logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. integer :: i0_last_thick_cell real :: u_orig ! The original value of the reconstruction in a cell [A] @@ -918,19 +823,6 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, xb = 1. u_sub(i_sub) = u0(i0) endif - if (debug_bounds) then - if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then - write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method - write(0,*) 'xa,xb: ',xa,xb - write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) - write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) - write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) - write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Sub-cell average is out of bounds!' ) - endif - endif if (force_bounds_in_subcell) then ! These next two lines should not be needed but when using PQM we found roundoff ! can lead to overshoots. These lines sweep issues under the rug which need to be From 40e6d6ddac2b36a3f6f35b9e99289f7d9acf26e8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 11 Apr 2024 17:14:32 -0400 Subject: [PATCH 032/128] Last refactor of remap_via_sub_cells() adding remap_sub_to_tgt_grid() - Added remap_sub_to_tgt_grid() to handle remapping of intermediate state on sub-layers to the target grid. This function will be reused by alternate remap_via_subcells() analogs for extensive quantities. - Added unit tests for remap_sub_to_tgt_grid(). --- src/ALE/MOM_remapping.F90 | 335 ++++++++++++++++++++++++-------------- 1 file changed, 210 insertions(+), 125 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index a5f470acad..ea7b1a3162 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -490,8 +490,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, optional, intent(out) :: aiss(n0) !< isrc_start integer, optional, intent(out) :: aise(n0) !< isrc_ens ! Local variables - integer :: i_sub ! Index of sub-cell - integer :: i1 ! Index into h1(1:n1), target column real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] @@ -502,61 +500,27 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - real :: dh ! The width of the sub-cell [H] - real :: duh ! The total amount of accumulated stuff (u*h) [A H] ! For error checking/debugging logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues real :: u02_err ! Integrated reconstruction error estimates [H A] - real :: u_orig ! The original value of the reconstruction in a cell [A] - real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Loop over each sub-cell to calculate average/integral values within each sub-cell. - ! Uses: h_sub, h0_eff, isub_src, h0_eff + ! Uses: h_sub, h0_eff, isub_src ! Sets: u_sub, uh_sub call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) ! Loop over each target cell summing the integrals from sub-cells within the target cell. - ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub - ! Sets: u1 - uh_err = 0. - do i1 = 1, n1 - if (h1(i1) > 0.) then - duh = 0. ; dh = 0. - i_sub = itgt_start(i1) - if (force_bounds_in_target) then - u1min = u_sub(i_sub) - u1max = u_sub(i_sub) - endif - do i_sub = itgt_start(i1), itgt_end(i1) - if (force_bounds_in_target) then - u1min = min(u1min, u_sub(i_sub)) - u1max = max(u1max, u_sub(i_sub)) - endif - dh = dh + h_sub(i_sub) - duh = duh + uh_sub(i_sub) - ! This accumulates the contribution to the error bound for the sum of u*h - uh_err = uh_err + max(abs(duh),abs(uh_sub(i_sub)))*epsilon(duh) - enddo - u1(i1) = duh / dh - ! This is the contribution from the division to the error bound for the sum of u*h - uh_err = uh_err + abs(duh)*epsilon(duh) - if (force_bounds_in_target) then - u_orig = u1(i1) - u1(i1) = max(u1min, min(u1max, u1(i1))) - ! Adjusting to be bounded contributes to the error for the sum of u*h - uh_err = uh_err + dh*abs( u1(i1)-u_orig ) - endif - else - u1(i1) = u_sub(itgt_start(i1)) - endif - enddo + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err @@ -869,6 +833,69 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, end subroutine remap_src_to_sub_grid +!> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 +subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & + itgt_start, itgt_end, force_bounds_in_target, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(in) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + integer, intent(in) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(in) :: itgt_end(n1) !< Index of last sub-cell within each target cell + logical, intent(in) :: force_bounds_in_target !< Force sub-cell values to be bounded + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + integer :: i1 ! tgt loop index + integer :: i_sub ! index to sub-layer + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] + real :: u_orig ! The original value of the reconstruction in a cell prior to bounding [A] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + uh_err = 0. + do i1 = 1, n1 + if (h1(i1) > 0.) then + duh = 0. ; dh = 0. + i_sub = itgt_start(i1) + if (force_bounds_in_target) then + u1min = u_sub(i_sub) + u1max = u_sub(i_sub) + endif + do i_sub = itgt_start(i1), itgt_end(i1) + if (force_bounds_in_target) then + u1min = min(u1min, u_sub(i_sub)) + u1max = max(u1max, u_sub(i_sub)) + endif + dh = dh + h_sub(i_sub) + duh = duh + uh_sub(i_sub) + ! This accumulates the contribution to the error bound for the sum of u*h + uh_err = uh_err + max(abs(duh),abs(uh_sub(i_sub)))*epsilon(duh) + enddo + u1(i1) = duh / dh + ! This is the contribution from the division to the error bound for the sum of u*h + uh_err = uh_err + abs(duh)*epsilon(duh) + if (force_bounds_in_target) then + u_orig = u1(i1) + u1(i1) = max(u1min, min(u1max, u1(i1))) + ! Adjusting to be bounded contributes to the error for the sum of u*h + uh_err = uh_err + dh*abs( u1(i1)-u_orig ) + endif + else + u1(i1) = u_sub(itgt_start(i1)) + endif + enddo + +end subroutine remap_sub_to_tgt_grid + !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) integer, intent(in) :: nsrc !< Number of source cells @@ -1438,16 +1465,14 @@ logical function remapping_unit_tests(verbose) 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) ! =============================================== ! This section tests the reconstruction functions ! =============================================== if (verbose) write(stdout,*) ' - - - - - reconstruction tests - - - - -' - allocate(ppoly0_coefs(5,6)) - allocate(ppoly0_E(5,2)) - allocate(ppoly0_S(5,2)) + allocate( ppoly0_coefs(5,6), ppoly0_E(5,2), ppoly0_S(5,2), u2(2) ) call PCM_reconstruction(3, (/1.,2.,4./), & ppoly0_E(1:3,:), ppoly0_coefs(1:3,:) ) @@ -1535,7 +1560,7 @@ logical function remapping_unit_tests(verbose) 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) if (verbose) write(stdout,*) ' - - - - - interpolation tests - - - - -' @@ -1596,19 +1621,23 @@ logical function remapping_unit_tests(verbose) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Test 3: n0=2, n1=3 With aligned interfaces that lead to implicitly-vanished interior sub-layers - ! h_src = | 2 | 4 | - ! h_tgt = | 2 | 2 | 2 | - ! h_sub = |0| 2 |0| 2 | 2 |0| - ! isrc_start |1 |3 | - ! isrc_end | 2 | 5 | - ! isrc_max | 2 | 5 | - ! itgt_start |1 | 4 | 5 | - ! itgt_end | 3| 4 | 6| - ! isub_src |1| 1 |2| 2 | 2 |2| - allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) - call intersect_src_tgt_grids( 2, (/2., 4./), & ! n0, h0 - 3, (/2., 2., 2./), & ! n1, h1 - h_sub, h0_eff, & + n0 = 2 ; n1 = 3 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 5. /) + h0 = (/ 2. , 4. /) + h1 = (/ 2. , 2. , 2. /) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 6| + ! isub_src |1| 1 |2| 2 | 2 |2| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) if (verbose) write(stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" if (verbose) write(stdout,*) " h_src = | 2 | 4 |" @@ -1621,36 +1650,50 @@ logical function remapping_unit_tests(verbose) call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') - allocate(ppoly0_coefs(2,2), ppoly0_E(2,2), ppoly0_S(2,2)) - ! h_src = |<- 2 ->|<- 4 ->| - ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| - ! u_src = | 2 | 5 | + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_src = | 2 | 5 | ! edge = |1 3|3 7| - ! u_sub = |1| 2 |3| 4 | 6 |7| - call PLM_reconstruction(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect ) - call PLM_boundary_extrapolation(2, (/2.,4./),(/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect) - allocate(u_sub(6), uh_sub(6)) - call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & - 3, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + ! u_sub = |1| 2 |3| 4 | 6 |7| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_sub = |1| 2 |3| 4 | 6 |7| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! u_tgt = | 2 | 4 | 6 | call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') - deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 6 | + ! isrc_max | 2 | 4 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 5 | + ! isub_src |1| 1 |2| 2 | 2 | 2 | + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) if (verbose) write(stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" if (verbose) write(stdout,*) " h_src = | 2 | 4 |" @@ -1663,36 +1706,40 @@ logical function remapping_unit_tests(verbose) call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') call test%int_arr(3, itgt_end, (/3,4,5/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') -! allocate(ppoly0_coefs(2,2), ppoly0_E(2,2), ppoly0_S(2,2)) + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) ! ! h_src = |<- 2 ->|<- 4 ->| ! ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| ! ! u_src = | 2 | 5 | ! ! edge = |1 3|3 7| ! ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | -! call PLM_reconstruction(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect ) -! call PLM_boundary_extrapolation(2, (/2.,4./),(/2.,5./), ppoly0_E, ppoly0_coefs, h_neglect) -! allocate(u_sub(6), uh_sub(6)) +! call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) +! call PLM_boundary_extrapolation(n0, h0, u0, poly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) ! call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & ! 3, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & ! INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) ! call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') -! deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - ! Test 5: n0=2, n1=3 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics - ! h_src = | 2 | 2 | 1 | - ! h_tgt = | 2 | 4 | - ! h_sub = |0| 2 |0| 2 | 1 | 1 | - ! isrc_start |1 |3 | 5 | - ! isrc_end | 2 | 4 | 5 | - ! isrc_max | 2 | 4 | 5 | | - ! itgt_start |1 | 4 | + ! Test 5: n0=3, n1=2 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics + n0 = 3 ; n1 = 2 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 4. , 5.5 /) + h0 = (/ 2. , 2. , 1. /) + h1 = (/ 2. , 4. /) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_tgt = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | ! itgt_end | 3| 6 | ! isub_src |1| 1 |2| 2 | 3 | 3 | - allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(3), itgt_end(3), isub_src(6) ) - call intersect_src_tgt_grids( 3, (/2., 2., 1./), & ! n0, h0 - 2, (/2., 4./), & ! n1, h1 - h_sub, h0_eff, & + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) if (verbose) write(stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" if (verbose) write(stdout,*) " h_src = | 2 | 2 | 1 |" @@ -1705,36 +1752,50 @@ logical function remapping_unit_tests(verbose) call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') - allocate(ppoly0_coefs(3,2), ppoly0_E(3,2), ppoly0_S(3,2)) - ! h_src = | 2 | 2 | 1 | - ! h_sub = |0| 2 |0| 2 | 1 | 1 | - ! u_src = | 2 | 4 | 5.5 | - ! edge = |1 3|3 5|5 6| - ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | - call PLM_reconstruction(3, (/2.,2.,1./), (/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, h_neglect ) - call PLM_boundary_extrapolation(3, (/2.,2.,1./),(/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, h_neglect) - allocate(u_sub(6), uh_sub(6)) - call remap_src_to_sub_grid(3, (/2.,2.,1./), (/2.,4.,5.5/), ppoly0_E, ppoly0_coefs, & - 2, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_src = | 2 | 4 | 5.5 | + ! edge = |1 3|3 5|5 6| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + ! h_tgt = |<- 2 ->|<- 4 ->| + ! u_tgt = | 2 | 4 7/8 | call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub) ! Test 6: n0=3, n1=5 Source and targets with vanished layers - ! h_src = | 2 |0| 2 | - ! h_tgt = | 1 |0| 1 |0| 2 | - ! h_sub = |0| 1 |0| 1 |0|0|0| 2 |0| - ! isrc_start |1 |5|6 | - ! isrc_end | 4 |5| 8 | - ! isrc_max | 4 |5| 8 | - ! itgt_start |1 |3| 4 |7| 8 | - ! itgt_end | 2 |3| 6|7| 9| - ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| - allocate( h_sub(9), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(5), itgt_end(5), isub_src(9) ) - call intersect_src_tgt_grids( 3, (/2., 0., 2./), & ! n0, h0 - 5, (/1., 0., 1., 0., 2./), & ! n1, h1 - h_sub, h0_eff, & + n0 = 3 ; n1 = 5 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. ,3., 4. /) + h0 = (/ 2. ,0., 2. /) + h1 = (/ 1. ,0., 1. ,0., 2. /) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! isrc_start |1 |5|6 | + ! isrc_end | 4 |5| 8 | + ! isrc_max | 4 |5| 8 | + ! itgt_start |1 |3| 4 |7| 8 | + ! itgt_end | 2 |3| 6|7| 9| + ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) if (verbose) write(stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" if (verbose) write(stdout,*) " h_src = | 2 |0| 2 |" @@ -1747,6 +1808,30 @@ logical function remapping_unit_tests(verbose) call test%int_arr(5, itgt_start, (/1,3,4,7,8/), 'itgt_start') call test%int_arr(5, itgt_end, (/2,3,6,7,9/), 'itgt_end') call test%int_arr(9, isub_src, (/1,1,1,1,2,3,3,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_src = | 2 |3| 4 | + ! edge = |1 3|3|3 5| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! u_tgt = | 1.5 |2| 2.5 |3| 4 | + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! ============================================================ From 88d9eb79fc60ddd07269aa5fd641c9c101df9515 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 22 May 2024 11:41:12 -0400 Subject: [PATCH 033/128] Fix remapping of last layer for mismatched ocean depths - The original remap_via_subcells() assumed that the first and last sub-layers would be vanished and thus needed to only assign the edge values of the source reconstructions to the sub-layers. However, this is only a valid assumption (and correct) if the total column thickness of source/target are the same. That is generally true doing the main loop. However, when initializing from WOA, the ocean model depth and source-data depth often differ, and this assumption that we can ignore the top/bottom reconstructions breaks. - The original fix was developed with @claireyung and took the form https://github.com/claireyung/MOM6/commit/924b7ac9cd27179327f536b1cabc5582ad717b92 In this patch, I have unrolled the loop inside remap_src_to_sub_grid() to avoid adding an additional `if` test on the loop index. - The fix is implemented in remap_src_to_sub_grid() and the original method is reached by setting a logical inside the remapping_CS. Default is to use the OM4 alorithm (original method with bug). - New runtime parameters are added in to recover original algorithm selectively: - OBC_REMAPPING_USE_OM4_SUBCELLS, - Z_INIT_REMAPPING_USE_OM4_SUBCELLS, - EBT_REMAPPING_USE_OM4_SUBCELLS, - SPONGE_REMAPPING_USE_OM4_SUBCELLS, - SPONGE_REMAPPING_USE_OM4_SUBCELLS, - DIAG_REMAPPING_USE_OM4_SUBCELLS, - NDIFF_REMAPPING_USE_OM4_SUBCELLS, - HBD_REMAPPING_USE_OM4_SUBCELLS, - INTWAVE_REMAPPING_USE_OM4_SUBCELLS, and - REMAPPING_USE_OM4_SUBCELLS all of which default to True. - No answer changes. --- src/ALE/MOM_ALE.F90 | 23 + src/ALE/MOM_remapping.F90 | 498 +++++++++++++++--- src/core/MOM_open_boundary.F90 | 6 + src/diagnostics/MOM_diagnostics.F90 | 7 +- src/diagnostics/MOM_wave_speed.F90 | 6 +- src/framework/MOM_diag_mediator.F90 | 7 +- src/framework/MOM_diag_remap.F90 | 6 +- .../MOM_state_initialization.F90 | 8 +- .../MOM_tracer_initialization_from_Z.F90 | 8 +- src/ocean_data_assim/MOM_oda_driver.F90 | 5 +- src/ocean_data_assim/MOM_oda_incupd.F90 | 6 +- .../lateral/MOM_internal_tides.F90 | 8 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 7 +- .../vertical/MOM_ALE_sponge.F90 | 12 + src/tracer/MOM_hor_bnd_diffusion.F90 | 16 +- src/tracer/MOM_neutral_diffusion.F90 | 6 + 16 files changed, 536 insertions(+), 93 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a083402fde..0ae5fb1e92 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -178,6 +178,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: local_logical logical :: remap_boundary_extrap logical :: init_boundary_extrap + logical :: om4_remap_via_sub_cells type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding ! for sharing parameters. @@ -234,6 +235,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "This selects the remapping algorithm used in OM4 that does not use "//& + "the full reconstruction for the top- and lower-most sub-layers, but instead "//& + "assumes they are always vanished (untrue) and so just uses their edge values. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -247,12 +253,14 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%answer_date) call initialize_remapping( CS%vel_remapCS, vel_string, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%answer_date) call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & @@ -326,6 +334,21 @@ subroutine ALE_set_extrap_boundaries( param_file, CS) call remapping_set_param(CS%remapCS, boundary_extrapolation=remap_boundary_extrap) end subroutine ALE_set_extrap_boundaries +!> Sets the remapping algorithm to that of OM4 +!! +!! The remapping aglorithm used in OM4 made poor assumptions about the reconstructions +!! in the top/bottom layers, namely that they were always vanished and could be +!! represented solely by their upper/lower edge value respectively. +!! Passing .false. here uses the full reconstruction of those top and bottom layers +!! and properly sample those layers. +subroutine ALE_set_OM4_remap_algorithm( CS, om4_remap_via_sub_cells ) + type(ALE_CS), pointer :: CS !< Module control structure + logical, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm + + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells =om4_remap_via_sub_cells ) + +end subroutine ALE_set_OM4_remap_algorithm + !> Initialize diagnostics for the ALE module. subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index ea7b1a3162..364a322f0f 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -5,7 +5,6 @@ module MOM_remapping ! Original module written by Laurent White, 2008.06.09 use MOM_error_handler, only : MOM_error, FATAL -use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_explicit_h4cw @@ -38,6 +37,9 @@ module MOM_remapping !> The vintage of the expressions to use for remapping. Values below 20190101 result !! in the use of older, less accurate expressions. integer :: answer_date = 99991231 + !> If true, use the OM4 version of the remapping algorithm that makes poor assumptions + !! about the reconstructions in top and bottom layers of the source grid + logical :: om4_remap_via_sub_cells = .false. end type !> Class to assist in unit tests @@ -111,13 +113,15 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -136,6 +140,9 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(om4_remap_via_sub_cells)) then + CS%om4_remap_via_sub_cells = om4_remap_via_sub_cells + endif if (present(answers_2018)) then if (answers_2018) then CS%answer_date = 20181231 @@ -171,6 +178,10 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex end subroutine extract_member_remapping_CS !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. +!! +!! \todo Remove h_neglect argument by moving into remapping_CS +!! \todo Remove PCM_cell argument by adding new method in Recon1D class +!! \todo Inline the two versions of remap_via_sub_cells() in remapping_core_h() to eliminate remap_via_sub_cells() 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 @@ -200,16 +211,26 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg 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, PCM_cell ) + 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) + if (CS%om4_remap_via_sub_cells) then - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) - if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & - n1, h1, u1, iMethod, uh_err, "remapping_core_h") + ! This calls the OM4 version of the remapmping algorithms + call remap_via_sub_cells_om4( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & + CS%force_bounds_in_subcell, u1, uh_err ) + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") + + else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + + 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 ) + + endif end subroutine remapping_core_h @@ -472,8 +493,11 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) +!! +!! This uses a buggy remap_via_sub_cells_om4() that produces the wrong value for +!! bottom layers that do not match the same total depth of the water column. +subroutine remap_via_sub_cells_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & + force_bounds_in_subcell, u1, uh_err) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] @@ -485,10 +509,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] - real, optional, intent(out) :: ah_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] - integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src - integer, optional, intent(out) :: aiss(n0) !< isrc_start - integer, optional, intent(out) :: aise(n0) !< isrc_ens ! Local variables real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] @@ -502,7 +522,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell ! For error checking/debugging logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues real :: u02_err ! Integrated reconstruction error estimates [H A] ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids @@ -512,7 +531,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Loop over each sub-cell to calculate average/integral values within each sub-cell. ! Uses: h_sub, h0_eff, isub_src ! Sets: u_sub, uh_sub - call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) @@ -525,10 +544,61 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err - if (present(ah_sub)) ah_sub(1:n0+n1+1) = h_sub(1:n0+n1+1) - if (present(aisub_src)) aisub_src(1:n0+n1+1) = isub_src(1:n0+n1+1) - if (present(aiss)) aiss(1:n0) = isrc_start(1:n0) - if (present(aise)) aise(1:n0) = isrc_end(1:n0) +end subroutine remap_via_sub_cells_om4 + +!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating +!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the +!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. +!! +!! \todo Remove h0_eff which is not needed +!! \todo Undo force_bounds_in_target when switching to Recon1D class +subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & + force_bounds_in_subcell, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + real :: u02_err ! Integrated reconstruction error estimates [H A] + + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err end subroutine remap_via_sub_cells @@ -577,7 +647,6 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & real :: dh ! The width of the sub-cell [H] real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging - logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues integer :: i0_last_thick_cell logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed @@ -716,7 +785,10 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & end subroutine intersect_src_tgt_grids !> Remaps column of n0 values u0 on grid h0 to subgrid h_sub -subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & +!! +!! This includes an error for the scenario where the source grid is much thicker than +!! the target grid and extrapolation is needed. +subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) integer, intent(in) :: n0 !< Number of cells in source grid @@ -747,7 +819,6 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, real :: dh0_eff ! Running sum of source cell thickness [H] real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues integer :: i0_last_thick_cell real :: u_orig ! The original value of the reconstruction in a cell [A] @@ -831,6 +902,147 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, enddo endif +end subroutine remap_src_to_sub_grid_om4 + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (adjust_thickest_subcell) then + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + endif + end subroutine remap_src_to_sub_grid !> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 @@ -1305,7 +1517,8 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1313,13 +1526,15 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Note that remapping_scheme is mandatory for initialize_remapping() call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018, answer_date=answer_date) + force_bounds_in_subcell=force_bounds_in_subcell, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date) end subroutine initialize_remapping @@ -1407,6 +1622,8 @@ logical function remapping_unit_tests(verbose) real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] type(testing) :: test ! Unit testing convenience functions + integer :: om4 + character(len=4) :: om4_tag call test%set( verbose=verbose ) ! Sets the verbosity flag in test @@ -1414,12 +1631,12 @@ logical function remapping_unit_tests(verbose) h_neglect = hNeglect_dflt h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - if (verbose) write(stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' + if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' ! This line carries out tests on some older remapping schemes. call test%test( remapping_attic_unit_tests(verbose), 'attic remapping unit tests' ) - if (verbose) write(stdout,*) ' - - - - - 1st generation tests - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) @@ -1466,11 +1683,12 @@ logical function remapping_unit_tests(verbose) call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) + call end_remapping(CS) ! =============================================== ! This section tests the reconstruction functions ! =============================================== - if (verbose) write(stdout,*) ' - - - - - reconstruction tests - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - reconstruction tests - - - - -' allocate( ppoly0_coefs(5,6), ppoly0_E(5,2), ppoly0_S(5,2), u2(2) ) @@ -1547,22 +1765,13 @@ logical function remapping_unit_tests(verbose) call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + ! ============================================================== - ! This section tests the components of remapping_via_sub_cells() + ! This section tests the components of remap_via_sub_cells() ! ============================================================== - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), h_neglect ) - call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - call test%real_arr(4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) - - if (verbose) write(stdout,*) ' - - - - - interpolation tests - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - remapping algororithm tests - - - - -' ! Test 1: n0=2, n1=3 Maps uniform grids with one extra target layer and no implicitly-vanished interior sub-layers ! h_src = | 3 | 3 | @@ -1579,9 +1788,9 @@ logical function remapping_unit_tests(verbose) 3, (/2., 2., 2./), & ! n1, h1 h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" - if (verbose) write(stdout,*) " h_src = | 3 | 3 |" - if (verbose) write(stdout,*) " h_tgt = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 3 | 3 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') call test%real_arr(2, h0_eff, (/3.,3./), 'h0_eff') call test%int_arr(2, isrc_start, (/1,4/), 'isrc_start') @@ -1607,9 +1816,9 @@ logical function remapping_unit_tests(verbose) 2, (/3., 3./), & ! n1, h1 h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" - if (verbose) write(stdout,*) " h_src = | 2 | 2 | 2 |" - if (verbose) write(stdout,*) " h_tgt = | 3 | 3 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 3 | 3 |" call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') call test%real_arr(3, h0_eff, (/2.,2.,2./), 'h0_eff') call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') @@ -1639,9 +1848,9 @@ logical function remapping_unit_tests(verbose) ! isub_src |1| 1 |2| 2 | 2 |2| call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" - if (verbose) write(stdout,*) " h_src = | 2 | 4 |" - if (verbose) write(stdout,*) " h_tgt = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" call test%real_arr(6, h_sub, (/0.,2.,0.,2.,2.,0./), 'h_sub') call test%real_arr(2, h0_eff, (/2.,4./), 'h0_eff') call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') @@ -1659,14 +1868,18 @@ logical function remapping_unit_tests(verbose) call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) - call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| ! u_sub = |1| 2 |3| 4 | 6 |7| ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| ! u_tgt = | 2 | 4 | 6 | - call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & .false., u1, u02_err) call test%real_arr(3, u1, (/2.,4.,6./), 'u1') @@ -1695,9 +1908,9 @@ logical function remapping_unit_tests(verbose) ! isub_src |1| 1 |2| 2 | 2 | 2 | call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" - if (verbose) write(stdout,*) " h_src = | 2 | 4 |" - if (verbose) write(stdout,*) " h_tgt = | 2 | 2 | 1 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 1 |" call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') call test%real_arr(2, h0_eff, (/2.,3./), 'h0_eff') call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') @@ -1707,18 +1920,18 @@ logical function remapping_unit_tests(verbose) call test%int_arr(3, itgt_end, (/3,4,5/), 'itgt_end') call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) -! ! h_src = |<- 2 ->|<- 4 ->| -! ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| -! ! u_src = | 2 | 5 | -! ! edge = |1 3|3 7| -! ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | -! call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) -! call PLM_boundary_extrapolation(n0, h0, u0, poly0_E, ppoly0_coefs, h_neglect) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) -! call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & -! 3, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & -! INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) -! call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') + call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & + 3, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) @@ -1741,9 +1954,9 @@ logical function remapping_unit_tests(verbose) ! isub_src |1| 1 |2| 2 | 3 | 3 | call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" - if (verbose) write(stdout,*) " h_src = | 2 | 2 | 1 |" - if (verbose) write(stdout,*) " h_tgt = | 2 | 4 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 1 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 4 |" call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') call test%real_arr(3, h0_eff, (/2.,2.,1./), 'h0_eff') call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') @@ -1761,14 +1974,18 @@ logical function remapping_unit_tests(verbose) call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) - call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | ! h_tgt = |<- 2 ->|<- 4 ->| ! u_tgt = | 2 | 4 7/8 | - call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & .false., u1, u02_err) call test%real_arr(2, u1, (/2.,4.875/), 'u1') @@ -1797,9 +2014,9 @@ logical function remapping_unit_tests(verbose) ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - if (verbose) write(stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" - if (verbose) write(stdout,*) " h_src = | 2 |0| 2 |" - if (verbose) write(stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" + if (verbose) write(test%stdout,*) " h_src = | 2 |0| 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" call test%real_arr(9, h_sub, (/0.,1.,0.,1.,0.,0.,0.,2.,0./), 'h_sub') call test%real_arr(3, h0_eff, (/2.,0.,2./), 'h0_eff') call test%int_arr(3, isrc_start, (/1,5,6/), 'isrc_start') @@ -1817,14 +2034,18 @@ logical function remapping_unit_tests(verbose) call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) - call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| ! u_tgt = | 1.5 |2| 2.5 |3| 4 | - call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & .false., u1, u02_err) call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1') @@ -1834,10 +2055,129 @@ logical function remapping_unit_tests(verbose) deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + ! ============================================================ + ! This section tests remap_via_sub_cells() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remap_via_sub_cells() tests - - - - - - - - -' + + allocate(ppoly0_E(4,2), ppoly0_S(4,2), ppoly0_coefs(4,3), u2(2)) + + ! These tests has vanished top and bottom layers with a linear profile + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, 0.) + ! Reconstruction has piecewise constant 5 and 1 for top and bottom layers respectively + ! but which are vanished so give no wieght to integrals. + ! Interface values are 5, 5, 3, 1, 1. + call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + call test%real_arr(4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + + ! Remapping to just the two interior layers yields the same values as u_src(2:3) + call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11 om4') + call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + + ! Remapping to two layers that are deeper. For the bottom layer of thickness 4, + ! the first 1/4 has average 2, the remaining 3/4 has the bottom edge value or 1 + ! yield ing and average or 1.25 + call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14 om4') + call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14') + + ! Remapping to two layers with lowest layer not reach the bottom. + ! Here, the bottom layer samples top half of source yeilding 2.5. + ! Note: OM4 used the value as if the target layer was the same thickness as source. + call remap_via_sub_cells_om4(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0440->h=42 om4 (with known bug)') + call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2.5/), 'PLM: remapped h=0440->h=42') + + ! Remapping to two layers with no layers sampling the bottom source layer + ! The first layer samples the top half of u1, yielding 4.5 + ! The second layer samples the next quarter of u1, yielding 3.75 + call remap_via_sub_cells_om4(4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/2.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.5,3.5/), 'PLM: remapped h=0880->h=21 om4 (with known bug)') + call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/2.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.5,3.75/), 'PLM: remapped h=0440->h=21') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + + ! ============================================================ + ! This section tests remapping_core_h() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' + + ! Profile 0: 8 layers, 1x top/2x bottom vanished, and the rest with thickness 1.0, total depth 5, u(z) = 1 + z + n0 = 8 + allocate( h0(n0), u0(n0) ) + h0 = (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) + allocate( u1(8) ) + + call initialize_remapping(CS, 'PLM', answer_date=99990101) + + do om4 = 0, 1 + if ( om4 == 0 ) then + CS%om4_remap_via_sub_cells = .false. + om4_tag(:) = ' ' + else + CS%om4_remap_via_sub_cells = .true. + om4_tag(:) = ' om4' + endif + + ! Unchanged grid + call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1, 1.e-17, 1.e-2) + call test%real_arr(8, u1, (/1.0,1.5,2.5,3.5,4.5,5.5,6.0,6.0/), 'PLM: remapped h=01111100->h=01111100'//om4_tag) + + ! Removing vanished layers (unchanged values for non-vanished layers, layer centers 0.5, 1.5, 2.5, 3.5, 4.5) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1, 1.e-17, 1.e-2) + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=11111'//om4_tag) + + ! Remapping to variable thickness layers (layer centers 0.25, 1.0, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1, 1.e-17, 1.e-2) + call test%real_arr(4, u1, (/1.25,2.,3.25,5./), 'PLM: remapped h=01111100->h=h1t2'//om4_tag) + + ! Remapping to variable thickness + vanished layers (layer centers 0.25, 1.0, 1.5, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1, 1.e-17, 1.e-2) + call test%real_arr(6, u1, (/1.25,2.,2.5,3.25,5.,6./), 'PLM: remapped h=01111100->h=h10t20'//om4_tag) + + ! Remapping to deeper water column (layer centers 0.75, 2.25, 3., 5., 8.) + call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1, 1.e-17, 1.e-2) + call test%real_arr(5, u1, (/1.75,3.25,4.,5.5,6./), 'PLM: remapped h=01111100->h=tt02'//om4_tag) + + ! Remapping to slightly shorter water column (layer centers 0.5, 1.5, 2.5,, 3.5, 4.25) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1, 1.e-17, 1.e-2) + if ( om4 == 0 ) then + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.25/), 'PLM: remapped h=01111100->h=1111h') + else + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=1111h om4 (known bug)') + endif + + ! Remapping to much shorter water column (layer centers 0.25, 0.5, 1.) + call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1, 1.e-17, 1.e-2) + if ( om4 == 0 ) then + call test%real_arr(3, u1, (/1.25,1.5,2./), 'PLM: remapped h=01111100->h=h01') + else + call test%real_arr(3, u1, (/1.25,1.5,1.875/), 'PLM: remapped h=01111100->h=h01 om4 (known bug)') + endif + + enddo ! om4 + + call end_remapping(CS) + deallocate( h0, u0, u1 ) + ! ============================================================ ! This section tests interpolation and reintegration functions ! ============================================================ - if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + if (verbose) write(test%stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' call test_interp(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & @@ -1875,7 +2215,7 @@ logical function remapping_unit_tests(verbose) 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) - if (verbose) write(stdout,*) ' - - - - - reintegration tests - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - reintegration tests - - - - -' call test_reintegrate(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 8394735cb9..3674e63c31 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -441,6 +441,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm character(len=64) :: remappingScheme ! This include declares and sets the variable "version". # include "version_variable.h" @@ -695,10 +696,15 @@ subroutine open_boundary_config(G, US, param_file, OBC) "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) endif ! OBC%number_of_segments > 0 diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index fd8057c38f..e5996826e2 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1580,6 +1580,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. logical :: split ! True if using the barotropic-baroclinic split algorithm + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. @@ -1617,6 +1618,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -1858,7 +1863,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then call wave_speed_init(CS%wave_speed, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + wave_speed_tol=wave_speed_tol, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 5caf47a51c..8ee271f315 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -1611,7 +1611,8 @@ end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) + remap_answer_date, better_speed_est, om4_remap_via_sub_cells, & + min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. @@ -1630,6 +1631,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! forms of the same remapping expressions. logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. + logical, optional, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + !! for calculating the EBT structure real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the @@ -1656,6 +1659,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) end subroutine wave_speed_init diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b3194af3d8..541e349d29 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3251,6 +3251,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for diagnostics character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3282,6 +3283,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "DIAG_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for diagnostics. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -3311,7 +3316,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date, GV=GV) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), om4_remap_via_sub_cells, remap_answer_date, GV) enddo deallocate(diag_coords) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index bbefa3808b..e8e6a756e9 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -92,6 +92,7 @@ module MOM_diag_remap !! vertical extents in [Z ~> m] for remapping extensive variables integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers + logical :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -102,10 +103,11 @@ module MOM_diag_remap contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) +subroutine diag_remap_init(remap_cs, coord_tuple, om4_remap_via_sub_cells, answer_date, GV) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME + logical, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -127,6 +129,7 @@ subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. + remap_cs%om4_remap_via_sub_cells = om4_remap_via_sub_cells remap_cs%answer_date = answer_date remap_cs%nz = 0 @@ -309,6 +312,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & answer_date=remap_cs%answer_date) remap_cs%initialized = .true. endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c18752c83d..3e71a98f55 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2504,6 +2504,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just character(len=64) :: remappingScheme real :: tempAvg ! Spatially averaged temperatures on a layer [C ~> degC] real :: saltAvg ! Spatially averaged salinities on a layer [S ~> ppt] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm (only used if useALEremapping) logical :: do_conv_adj, ignore integer :: nPoints integer :: id_clock_routine, id_clock_ALE @@ -2583,6 +2584,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -2753,7 +2758,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the target grid (and set the model thickness to it) call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) ! Now remap from source grid to target grid, first setting reconstruction parameters if (remap_general) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index cac8a5cd6c..bafa5d8c36 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -96,6 +96,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! remapping cell reconstructions [Z ~> m] real :: dz_neglect_edge ! A negligibly small vertical layer extent used in ! remapping edge value calculations [Z ~> m] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -137,6 +138,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -174,7 +179,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) ! Set parameters for reconstructions - call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 8453ceb497..9275555afc 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -183,6 +183,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -320,8 +321,10 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & "Coordinate mode for vertical regridding.", & default="ZSTAR", fail_if_missing=.false.) + call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS,remap_scheme) + call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells) call set_regrid_params(CS%regridCS, min_thickness=0.) isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index d54d34506e..94d09554c2 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -143,6 +143,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re real :: dt, dt_therm ! Model timesteps [T ~> s] character(len=256) :: mesg character(len=64) :: remapScheme + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") @@ -195,6 +197,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re "When defined, the incoming oda_incupd data are "//& "assumed to be on the model horizontal grid " , & default=.true.) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) CS%nz = GV%ke @@ -236,7 +240,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! Call the constructor for remapping control structure !### Revisit this hard-coded answer_date. call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answer_date=20190101) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=20190101) end subroutine initialize_oda_incupd diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 5b9ce4934c..225781ce0c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2550,6 +2550,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags ! of cells with double-reflecting ridges [nondim] logical :: use_int_tides, use_temperature + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. real :: kappa_h2_factor ! A roughness scaling factor [nondim] @@ -2726,6 +2727,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "mode speeds are not calculated but are simply reported as 0. This must be "//& "non-negative for the wave_speeds routine to be used.", & units="m s-1", default=0.01, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & "If positive, a uniform group velocity of internal tide for test case", & @@ -3107,7 +3112,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo ! Initialize the module that calculates the wave speeds. - call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) + call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells) end subroutine internal_tides_init diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index cd7e235274..7db0dc4e90 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1190,6 +1190,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! mode wave speed as the starting point for iterations. real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. @@ -1593,10 +1594,14 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "EBT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) endif ! Leith parameters diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index f1739485d6..af33806a90 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -190,6 +190,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, logical :: data_h_to_Z logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -234,6 +235,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& @@ -284,6 +289,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & @@ -468,6 +474,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -510,6 +517,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& @@ -549,6 +560,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 13e91e8973..b6714148ea 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -89,6 +89,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! local variables character(len=80) :: string ! Temporary strings logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for HBD logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then @@ -142,10 +143,15 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "HBD_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for horizontal boundary diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false.) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & @@ -849,8 +855,9 @@ 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., & + om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. + 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. @@ -1040,6 +1047,7 @@ logical function near_boundary_unit_tests( verbose ) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + ! ### This test fails when om4_remap_via_sub_cells=.false. near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 402a008244..6b60769144 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -152,6 +152,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, logical :: debug ! If true, write verbose checksums for debugging purposes. logical :: boundary_extrap ! Indicate whether high-order boundary !! extrapolation should be used within boundary cells. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -232,8 +233,13 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(param_file, mdl, "NDIFF_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & From 7cea6dd1b6be3b1265d6d6bce433707e4941a335 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 4 Jun 2024 12:33:17 -0400 Subject: [PATCH 034/128] Replace kind=8 with iso_fortran_env kinds This patch replaces references to kind=8 with the corresponding Fortran kind identifiers as defined in iso_fortran_env. Although these are widely equal to 8, there are a number of compilers (notably NAG, also others) which set it to a different value. This improves the portability of the code (albeit in a rather minor way). --- .../external/drifters/MOM_particles_types.F90 | 9 +-- .../infra/FMS1/MOM_diag_manager_infra.F90 | 5 +- .../infra/FMS2/MOM_diag_manager_infra.F90 | 5 +- src/framework/MOM_coms.F90 | 69 ++++++++++--------- src/framework/MOM_intrinsic_functions.F90 | 2 +- src/framework/MOM_restart.F90 | 15 ++-- 6 files changed, 55 insertions(+), 50 deletions(-) diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index 51e744a186..30fecad7a2 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -3,6 +3,7 @@ module particles_types_mod ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_grid, only : ocean_grid_type use MOM_domains, only: domain2D @@ -75,7 +76,7 @@ module particles_types_mod real :: vvel_old !< Previous meridional velocity component (m/s) integer :: year !< Year of this record integer :: particle_num !< Current particle number - integer(kind=8) :: id = -1 !< Particle Identifier + integer(kind=int64) :: id = -1 !< Particle Identifier type(xyt), pointer :: next=>null() !< Pointer to the next position in the list end type xyt @@ -98,8 +99,8 @@ module particles_types_mod real :: start_day !< origination position (degrees) and day integer :: start_year !< origination year real :: halo_part !< equal to zero for particles on the computational domain, and 1 for particles on the halo - integer(kind=8) :: id !< particle identifier - integer(kind=8) :: drifter_num !< particle identifier + integer(kind=int64) :: id !< particle identifier + integer(kind=int64) :: drifter_num !< particle identifier integer :: ine !< nearest i-index in NE direction (for convenience) integer :: jne !< nearest j-index in NE direction (for convenience) real :: xi !< non-dimensional x-coordinate within current cell (0..1) @@ -147,7 +148,7 @@ module particles_types_mod logical :: ignore_traj=.False. !< If true, then model does not write trajectory data at all logical :: use_new_predictive_corrective =.False. !< Flag to use Bob's predictive corrective particle scheme !Added by Alon - integer(kind=8) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id + integer(kind=int64) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id type(buffer), pointer :: obuffer_n=>null() !< Buffer for outgoing parts to the north type(buffer), pointer :: ibuffer_n=>null() !< Buffer for incoming parts from the north type(buffer), pointer :: obuffer_s=>null() !< Buffer for outgoing parts to the south diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 232986f480..d9be18d33f 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -359,7 +360,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -382,7 +383,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index f05baa4474..57f92c2046 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -361,7 +362,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -384,7 +385,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index e7c38d988d..e4f5235da8 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -4,6 +4,7 @@ module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 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 @@ -25,7 +26,7 @@ module MOM_coms ! This module provides interfaces to the non-domain-oriented communication subroutines. -integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. +integer(kind=int64), parameter :: prec = (2_int64)**46 !< The precision of each integer. real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. integer, parameter :: max_count_prec=2**(63-46)-1 @@ -73,7 +74,7 @@ module MOM_coms !! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. !! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=8), dimension(ni) :: v !< The value in this type + integer(kind=int64), dimension(ni) :: v !< The value in this type end type EFP_type !> Add two extended-fixed-point numbers @@ -115,8 +116,8 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: ival, prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: ival, prec_error real :: rs ! The remaining value to add, in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] logical :: over_check, do_sum_across_PEs @@ -127,7 +128,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -176,7 +177,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, sgn = 1 ; if (array(i,j)<0.0) sgn = -1 rs = abs(array(i,j)) do n=1,ni - ival = int(rs*I_pr(n), 8) + ival = int(rs*I_pr(n), kind=int64) rs = rs - ival*pr(n) ints_sum(n) = ints_sum(n) + sgn*ival enddo @@ -245,8 +246,8 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: prec_error real :: rsum(1) ! The running sum, in arbitrary units [a] logical :: repro, do_sum_across_PEs character(len=256) :: mesg @@ -257,7 +258,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -349,9 +350,9 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su real :: val ! The real number that is extracted in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8), dimension(ni,size(array,3)) :: ints_sums - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(ni,size(array,3)) :: ints_sums + integer(kind=int64) :: prec_error character(len=256) :: mesg logical :: do_sum_across_PEs integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n @@ -360,7 +361,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() max_mag_term = 0.0 is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) @@ -508,23 +509,23 @@ end function reproducing_sum_3d !> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) real, intent(in) :: r !< The real number being converted in arbitrary units [a] - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented - integer(kind=8), dimension(ni) :: ints + integer(kind=int64), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg - integer(kind=8) :: ival, prec_err + integer(kind=int64) :: ival, prec_err integer :: sgn, i prec_err = prec ; if (present(prec_error)) prec_err = prec_error - ints(:) = 0_8 + ints(:) = 0 if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif sgn = 1 ; if (r<0.0) sgn = -1 @@ -539,7 +540,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) ints(i) = sgn*ival enddo @@ -549,7 +550,7 @@ end function real_to_ints !> Convert the array of integers that constitute an extended-fixed-point !! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers + integer(kind=int64), dimension(ni), intent(in) :: ints !< The array of EFP integers real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. @@ -562,9 +563,9 @@ end function ints_to_real !> Increment an array of integers that constitutes an extended-fixed-point !! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -596,7 +597,7 @@ end subroutine increment_ints !> Increment an EFP number with a real number without doing any carrying of !! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented real, intent(in) :: r !< The real number being added in arbitrary units [a] real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's !! in arbitrary units [a] @@ -605,7 +606,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) ! representation in real_to_ints, but without doing any carrying of overflow. ! The entire operation is embedded in a single call for greater speed. real :: rs ! The remaining value to add, in arbitrary units [a] - integer(kind=8) :: ival + integer(kind=int64) :: ival integer :: sgn, i if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif @@ -620,7 +621,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) int_sum(i) = int_sum(i) + sgn*ival enddo @@ -629,9 +630,9 @@ end subroutine increment_ints_faster !> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being !! modified by carries, but without changing value. - integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -653,7 +654,7 @@ end subroutine carry_overflow !> This subroutine carries the overflow, and then makes sure that !! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), & + integer(kind=int64), dimension(ni), & intent(inout) :: int_sum !< The array of integers being modified to take a !! regular form with all integers of the same sign, !! but without changing value. @@ -799,8 +800,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni,nval) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni,nval) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: i, n @@ -809,7 +810,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. @@ -846,8 +847,8 @@ subroutine EFP_val_sum_across_PEs(EFP, error) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: n @@ -856,7 +857,7 @@ subroutine EFP_val_sum_across_PEs(EFP, error) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 3fd9ace1ad..fdafa8503d 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -176,7 +176,7 @@ pure function descale(x, e_a, s_a) result(a) ! Biased exponent of x ! Apply the corrected exponent and sign to x. - xb = transfer(x, 1_8) + xb = transfer(x, 1_int64) e_x = ibits(xb, expbit, explen) call mvbits(e_a + e_x, 0, explen, xb, expbit) call mvbits(s_a, 0, 1, xb, signbit) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 06f4abc065..44dee97a76 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -3,6 +3,7 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_checksums, only : chksum => rotated_field_chksum use MOM_domains, only : PE_here, num_PEs, AGRID, BGRID_NE, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -1348,12 +1349,12 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. - integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + integer(kind=int64) :: var_sz, size_in_file ! The size in bytes of each variable ! and the variables already in a file. - integer(kind=8), parameter :: max_file_size = 4294967292_8 ! The maximum size in bytes for the + integer(kind=int64), parameter :: max_file_size = 4294967292_int64 ! The maximum size in bytes for the ! starting position of each variable in a file's record, ! based on the use of NetCDF 3.6 or later. For earlier - ! versions of NetCDF, the value was 2147483647_8. + ! versions of NetCDF, the value was 2147483647_int64. integer :: start_var, next_var ! The starting variables of the ! current and next files. type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset @@ -1365,7 +1366,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ real :: restart_time ! The model time at whic the restart file is being written [days] character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. - integer(kind=8) :: check_val(CS%max_fields,1) + integer(kind=int64) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns integer, parameter :: nmax_extradims = 5 @@ -1570,8 +1571,8 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. - integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. - integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. + integer(kind=int64) :: checksum_file ! The checksum value recorded in the input file. + integer(kind=int64) :: checksum_data ! The checksum value for the data that was read in. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") @@ -2182,7 +2183,7 @@ function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_s character(len=8), intent(in) :: t_grid !< A time string to interpret type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: num_z !< The number of vertical layers in the grid - integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + integer(kind=int64) :: var_sz !< The function result, the size in bytes of a variable ! Local variables integer :: var_periods ! The number of entries in a time-periodic axis From f596c819374688d4546c8783ba844366c9c1d21e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 30 Apr 2024 13:55:50 -0400 Subject: [PATCH 035/128] +(*)Fix problems with generic_tracer_min_max Revise MOM_generic_tracer_min_max and array_global_min_max to fix several problems that had previously been noted, and to make the location arguments optional, reflecting that they are optional in the calling routine. This requires a revision to the order of arguments to MOM_generic_tracer_min_max. The interface to array_global_min_max was extensively revised and simplified to replace several previous arguments with a single new ocean_grid_type argument, to make the location arguments optional, and add an optional unscale argument. This commit fixes a number of problems that had previously been noted with array_global_min_max, including that: (1) It actually returns the global minimum and maximum values of the tracer; (2) It gives a position that is independent of the domain decomposition and grid rotation; (3) For all-zero arrays it correctly reports 0 for the minimum and maximum; (4) It properly handles unscaling of the input array; (5) It does not use a 3-d mask array that is actually just a 2-d mask array; (6) It is more efficient by grouping the global minimum and maximum calls. This commit also adds or revises comments to document the units and purpose of the remaining undocumented real variables in MOM_generic_tracer.F90. These changes were tested and verified to be correct by calling array_global_min_max for temperatures and salinities from write_energy, but those changes were not included in this commit. This commit also adds an optional verbosity argument to g_tracer_flux_init in config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90, reflecting a change to ocean_BGC/generic_tracers/generic_tracer_utils.F90 that was adopted in August of 2020, and is uses this new verbosity argument in the call from MOM_generic_flux_init. While all solutions are bitwise identical, there are changes (corrections) in some diagnostic output, and there are changes to the arguments of publicly visible routines. --- .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 3 +- src/tracer/MOM_generic_tracer.F90 | 364 +++++++++++------- src/tracer/MOM_tracer_flow_control.F90 | 7 +- 3 files changed, 223 insertions(+), 151 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index fec9c80461..5c87c37e70 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -99,8 +99,9 @@ module g_tracer_utils contains !> Unknown - subroutine g_tracer_flux_init(g_tracer) + subroutine g_tracer_flux_init(g_tracer, verbosity) type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity end subroutine g_tracer_flux_init !> Unknown diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index f430e94515..6168ec1d70 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -67,7 +67,7 @@ module MOM_generic_tracer public end_MOM_generic_tracer, MOM_generic_tracer_get public MOM_generic_tracer_stock public MOM_generic_flux_init - public MOM_generic_tracer_min_max + public MOM_generic_tracer_min_max, array_global_min_max public MOM_generic_tracer_fluxes_accumulate public register_MOM_generic_tracer_segments @@ -206,7 +206,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !!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. + ! Register prognostic 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, & @@ -699,42 +699,49 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde end function MOM_generic_tracer_stock - !> This subroutine find the global min and max of either of all - !! available tracer concentrations, or of a tracer that is being - !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & - xgmax, ygmax, zgmax , G, CS, names, units) + !> This subroutine finds the global min and max of either of all available + !! tracer concentrations, or of a tracer that is being requested specifically, + !! returning the number of tracers it has evaluated. + !! It also optionally returns the locations of the extrema. + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) integer, intent(in) :: ind_start !< The index of the tracer to start with logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and !! max are found for each tracer - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure 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. + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] integer :: MOM_generic_tracer_min_max !< Return value, the !! number of tracers done here. -! Local variables + ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr + real, dimension(:,:,:,:), pointer :: tr_field ! The tracer array whose extrema are being sought [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! The tracer array whose extrema are being sought [conc] + real :: x_min ! The x-position of the global minimum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_min ! The y-position of the global minimum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_min ! The z-position of the global minimum [layer] + real :: x_max ! The x-position of the global maximum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_max ! The y-position of the global maximum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_max ! The z-position of the global maximum [layer] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' - real, dimension(:,:,:),pointer :: grid_tmask - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - + logical :: find_location + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau integer :: k, is, ie, js, je, m - real, allocatable, dimension(:) :: geo_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -743,19 +750,14 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) - - ! Because the use of a simple z-coordinate can not be assumed, simply - ! use the layer index as the vertical label. - allocate(geo_z(nk)) - do k=1,nk ; geo_z(k) = real(k) ; enddo + call g_tracer_get_common(isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau) + find_location = present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax) m=ind_start ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) gmin(m) = -1.0 @@ -763,9 +765,18 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg tr_ptr => tr_field(:,:,:,1) - call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & - G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & - xgmax(m), ygmax(m), zgmax(m)) + if (find_location) then + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m), & + x_min, y_min, z_min, x_max, y_max, z_max) + if (present(xgmin)) xgmin(m) = x_min + if (present(ygmin)) ygmin(m) = y_min + if (present(zgmin)) zgmin(m) = z_min + if (present(xgmax)) xgmax(m) = x_max + if (present(ygmax)) ygmax(m) = y_max + if (present(zgmax)) zgmax(m) = z_max + else + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m)) + endif got_minmax(m) = .true. @@ -780,133 +791,192 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg end function MOM_generic_tracer_min_max - !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. - subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & - geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - integer, intent(in) :: isd !< The starting data domain i-index - integer, intent(in) :: jsd !< The starting data domain j-index - real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema - real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude - integer, intent(in) :: isc !< The starting compute domain i-index - integer, intent(in) :: iec !< The ending compute domain i-index - integer, intent(in) :: jsc !< The starting compute domain j-index - integer, intent(in) :: jec !< The ending compute domain j-index +!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. +!! When there multiple cells with the same extreme values, the reported locations are from the +!! uppermost layer where they occur, and then from the logically northernmost and then eastermost +!! such location on the unrotated version of the grid within that layer. Only ocean points (as +!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points +!! anywhere in the domain, the reported extrema and their locations are all returned as 0. + subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) integer, intent(in) :: nk !< The number of vertical levels - real, intent(out) :: g_min !< The global minimum of tr_array - real, intent(out) :: g_max !< The global maximum of tr_array - real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points - real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points - real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points - real, intent(out) :: xgmin !< The x-position of the global minimum - real, intent(out) :: ygmin !< The y-position of the global minimum - real, intent(out) :: zgmin !< The z-position of the global minimum - real, intent(out) :: xgmax !< The x-position of the global maximum - real, intent(out) :: ygmax !< The y-position of the global maximum - real, intent(out) :: zgmax !< The z-position of the global maximum - - ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() - ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match - ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with - ! added comments to document its arguments.i - - !### The obvious problems with this routine as currently written include: - ! 1. It does not return exactly the maximum and minimum values. - ! 2. The reported maximum and minimum are dependent on PE count and layout. - ! 3. For all-zero arrays, the reported maxima scale with the PE_count - ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed - ! 1e10, the values it returns are simply wrong. - ! 5. The results do not scale appropriately if the argument is rescaled. - ! 6. The extrema and locations are not rotationally invariant. - ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for + !! extrema in arbitrary concentration units [CU ~> conc] + real, intent(out) :: g_min !< The global minimum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, intent(out) :: g_max !< The global maximum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of + !! the input tracer array [conc CU-1 ~> 1] ! Local variables - real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array - real :: tmax0, tmin0 ! First-guest values of tmax and tmin. + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] + integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values + real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and + ! maximum values in units that vary between the array elements [various] + logical :: valid_PE ! True if there are any valid points on the local PE. + logical :: find_location ! If true, report the locations of the extrema + integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE + integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE + integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema [nondim]. - - ! arrays to enable vectorization - integer :: iminarr(3), imaxarr(3) - - !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. - g_min = -88888888888.0 ; g_max = -999999999.0 - tmax = -1.e10 ; tmin = 1.e10 - itmax = 0 ; jtmax = 0 ; ktmax = 0 - itmin = 0 ; jtmin = 0 ; ktmin = 0 - - if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then - ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. - iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - itmin = iminarr(1)+isc-1 - jtmin = iminarr(2)+jsc-1 - ktmin = iminarr(3) - itmax = imaxarr(1)+isc-1 - jtmax = imaxarr(2)+jsc-1 - ktmax = imaxarr(3) - tmin = tr_array(itmin,jtmin,ktmin) - tmax = tr_array(itmax,jtmax,ktmax) - end if - - ! use "fudge" to distinguish processors when tracer extreme is independent of processor - !### This fudge factor is not independent of PE layout, and while it mostly works for finding - ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite - ! cases, for which the fudge factor should be slightly reduced. The fudge factor should - ! be based on global index-space conventions, which are decomposition invariant, and - ! not the PE-number! - fudge = 1.0 + 1.e-12*real(PE_here() ) - tmax = tmax*fudge - tmin = tmin*fudge - if (tmax == 0.0) then - tmax = tmax + 1.e-12*real(PE_here() ) - endif - if (tmin == 0.0) then - tmin = tmin + 1.e-12*real(PE_here() ) + integer :: i, j, k, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax)) + + ! The initial values set here are never used if there are any valid points. + tmax = -huge(tmax) ; tmin = huge(tmin) + + if (find_location) then + ! Find the maximum and minimum tracer values on this PE and their locations. + valid_PE = .false. + itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + valid_PE = .true. + if (tr_array(i,j,k) > tmax) then + tmax = tr_array(i,j,k) + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_max) then + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc_here + endif + endif + if (tr_array(i,j,k) < tmin) then + tmin = tr_array(i,j,k) + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_min) then + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc_here + endif + endif + endif ; enddo ; enddo ; enddo + else + ! Only the maximum and minimum values are needed, and not their positions. + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) + if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) + endif ; enddo ; enddo ; enddo endif - tmax0 = tmax ; tmin0 = tmin + ! Find the global maximum and minimum tracer values. + g_max = tmax ; g_min = tmin + call max_across_PEs(g_max) + call min_across_PEs(g_min) - call max_across_PEs(tmax) - call min_across_PEs(tmin) + if (find_location) then + if (g_max < g_min) then + ! This only occurs if there are no unmasked points anywhere in the domain. + xyz_min_max(:) = 0.0 + else + ! Find the global indices of the maximum and minimum locations. This can + ! occur on multiple PEs. + ijk_min_max(1:2) = 0 + if (valid_PE) then + if (g_min == tmin) ijk_min_max(1) = ijk_loc_min + if (g_max == tmax) ijk_min_max(2) = ijk_loc_max + endif + ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: + ! call max_across_PEs(ijk_min_max, 2) + call max_across_PEs(ijk_min_max(1)) + call max_across_PEs(ijk_min_max(2)) + + ! Set the positions of the extrema if they occur on this PE. This will only + ! occur on a single PE. + xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. + if (valid_PE) then + if (ijk_min_max(1) == ijk_loc_min) then + xyz_min_max(1) = G%geoLonT(itmin,jtmin) + xyz_min_max(2) = G%geoLatT(itmin,jtmin) + xyz_min_max(3) = real(ktmin) + endif + if (ijk_min_max(2) == ijk_loc_max) then + xyz_min_max(4) = G%geoLonT(itmax,jtmax) + xyz_min_max(5) = G%geoLatT(itmax,jtmax) + xyz_min_max(6) = real(ktmax) + endif + endif - g_max = tmax - g_min = tmin + call max_across_PEs(xyz_min_max, 6) + endif - ! Now find the location of the global extrema. - ! - ! Note that the fudge factor above guarantees that the location of max (min) is unique, - ! since tmax0 (tmin0) has slightly different values on each processor. - ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more - ! than one point in space and this would be a much more difficult problem to solve. - ! - !-999 on all current PE's - xgmax = -999. ; ygmax = -999. ; zgmax = -999. - xgmin = -999. ; ygmin = -999. ; zgmin = -999. - - if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. - xgmax = geo_x(itmax,jtmax) - ygmax = geo_y(itmax,jtmax) - zgmax = geo_z(ktmax) + if (present(xgmin)) xgmin = xyz_min_max(1) + if (present(ygmin)) ygmin = xyz_min_max(2) + if (present(zgmin)) zgmin = xyz_min_max(3) + if (present(xgmax)) xgmax = xyz_min_max(4) + if (present(ygmax)) ygmax = xyz_min_max(5) + if (present(zgmax)) zgmax = xyz_min_max(6) endif - !### These three calls and the three calls that follow in about 10 lines should be combined - ! into a single call for efficiency. - call max_across_PEs(xgmax) - call max_across_PEs(ygmax) - call max_across_PEs(zgmax) - - if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. - xgmin = geo_x(itmin,jtmin) - ygmin = geo_y(itmin,jtmin) - zgmin = geo_z(ktmin) + if (g_max < g_min) then + ! There are no unmasked points anywhere in the domain. + g_max = 0.0 ; g_min = 0.0 endif - call max_across_PEs(xgmin) - call max_across_PEs(ygmin) - call max_across_PEs(zgmin) + if (present(unscale)) then + ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] + g_max = unscale * g_max + g_min = unscale * g_min + endif end subroutine array_global_min_max + ! Return a positive integer encoding the rotationally invariant global position of a tracer cell + function ijk_loc(i, j, k, nk, HI) + integer, intent(in) :: i !< Local i-index + integer, intent(in) :: j !< Local j-index + integer, intent(in) :: k !< Local k-index + integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + integer :: ijk_loc ! An integer encoding the cell position in the global grid. + + ! Local variables + integer :: ig, jg ! Global index values with a global computational domain start value of 1. + integer :: ij_loc ! The encoding of the horizontal position + integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone + + ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. + ig = i + HI%idg_offset + (1 - HI%isg) + jg = j + HI%jdg_offset + (1 - HI%jsg) + + ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. + qturns = modulo(HI%turns, 4) + if (qturns == 0) then + ij_loc = ig + HI%niglobal * jg + elseif (qturns == 1) then + ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) + elseif (qturns == 2) then + ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) + elseif (qturns == 3) then + ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig + endif + + ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) + + end function ijk_loc + !> This subroutine calculates the surface state and sets coupler values for !! those generic tracers that have flux exchange with atmosphere. !! @@ -983,7 +1053,7 @@ subroutine MOM_generic_flux_init(verbosity) g_tracer=>g_tracer_list do - call g_tracer_flux_init(g_tracer) !, verbosity=verbosity) !### Add this after ocean shared is updated. + call g_tracer_flux_init(g_tracer, verbosity=verbosity) ! 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 ca85fc234f..2f1ebd2635 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -746,9 +746,10 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock 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 ,& - G, CS%MOM_generic_tracer_CSp,names, units) + if (present(got_min_max) .and. present(global_min) .and. present(global_max)) & + nn = MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + G, CS%MOM_generic_tracer_CSp, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) endif if (CS%use_pseudo_salt_tracer) then From ac9d6a4e9710b263f9b69b8e7914df7ce6bb2f86 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 9 Jul 2024 04:01:16 -0400 Subject: [PATCH 036/128] Autoconf: Disable LDFLAGS for C testing (#674) Certain compilers would expect values passed to ld which cannot be passed to the C compiler. This caused the autoconf C configuration to fail, since it uses to CC for linking rather than LD. Since we never use the C compiler for linking, this is not something we need to be concerned about, and the LDFLAGS is disabled when testing the C compiler. This is only a concern when using certain GPU-related flags in the Nvidia compiler, and is only a problem for libraries with a significant amount of C code, such as FMS. --- .testing/Makefile | 2 +- ac/configure.ac | 4 ++-- ac/deps/configure.fms.ac | 16 ++++++++++++++-- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 83dd7dc478..085fea2655 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -651,7 +651,7 @@ $(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @./tools/report_test_results.sh $(WORK)/results + ./tools/report_test_results.sh $(WORK)/results #--- diff --git a/ac/configure.ac b/ac/configure.ac index 8196e2eb01..071f43f5a9 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -81,8 +81,8 @@ AS_IF([test "x$with_driver" != "x"], # Explicitly assume free-form Fortran -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) # Determine MPI compiler wrappers diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index a52533970b..7d68daa3c7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -10,7 +10,16 @@ AC_INIT( AC_CONFIG_SRCDIR([fms/fms.F90]) AC_CONFIG_MACRO_DIR([m4]) + # C configuration + +# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is +# not valid in some compilers. This can cause basic CC tests to fail. +# Since we do not link with CC, we can safely disable LDFLAGS for AC_PROG_CC. +FC_LDFLAGS="$LDFLAGS" +LDFLAGS="" + +# C compiler verification AC_PROG_CC AX_MPI CC=$MPICC @@ -55,10 +64,13 @@ AC_CHECK_FUNCS([gettid], [], [ # FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) +# Restore LDFLAGS +LDFLAGS="$FC_LDFLAGS" + # Standard Fortran configuration -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) AC_PROG_FC From 659d19b58de2c6b6f2ce93afd267d122d7a3c1e8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 6 Jun 2024 18:42:20 -0400 Subject: [PATCH 037/128] (*)Fix bug in rotate_ALE_sponge for fixed sponges Corrected a bug in rotate_ALE_sponge that incorrectly set the starting number of sponge fields that prevented any cases with fixed ALE sponges from working when ROTATE_INDEX is true, even if INDEX_TURNS is 0. With this correction, the code is now working (and giving identical answers) with rotation enabled for cases with fixed ALE_sponges. All answers are bitwise identical in cases that worked before, but some cases that did not work at all are now working both with and without grid rotation. --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index af33806a90..170265d27a 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -1315,11 +1315,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! Second part: Provide rotated fields for which relaxation is applied - sponge%fldno = sponge_in%fldno - if (fixed_sponge) then allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + ! For a fixed sponge, sponge%fldno is incremented from 0 in the calls to set_up_ALE_sponge_field. + sponge%fldno = 0 + else + sponge%fldno = sponge_in%fldno endif do n=1,sponge_in%fldno @@ -1372,8 +1374,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! TODO: var_u and var_v sponge damping is not yet supported. if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & - call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & - // "implemented.") + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet implemented.") ! Transfer any existing diag_CS reference pointer sponge%diag => sponge_in%diag From f8f127c454f9524f41ff05fcf70efed719b49d5c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jun 2024 11:29:21 -0400 Subject: [PATCH 038/128] +Renamed myStats scale argument to unscale Renamed the optional scale argument to myStats to unscale, mirroring the recent additions of unscale arguments to the various chksum routines. This included changes to 6 calls to myStats in the two horiz_interp_and_extrap_tracer routines. Although myStats is public, it really is only used in MOM_horizontal_regridding in the main version of MOM6, apart from a single call in MOM_initialize_tracer_from_Z that does not use the optional unscale argument, so rather than adding a second optional argument, this case seemed to be safe enough to rename the argument in place. If there were any unanticipated problems with this argument name change, they would be manifest in code that does not compile. All answers are bitwise identical, but an optional argument (scale) to a publicly visible diagnostic routine (myStats) was renamed. --- src/framework/MOM_horizontal_regridding.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1d5eab106d..719eb7d9e4 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -44,14 +44,15 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, G, k, mesg, scale, full_halo) +subroutine myStats(array, missing, G, k, mesg, unscale, full_halo) type(ocean_grid_type), intent(in) :: G !< Ocean grid type real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: array !< input array in arbitrary units [A ~> a] real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] integer, intent(in) :: k !< Level to calculate statistics for character(len=*), intent(in) :: mesg !< Label to use in message - real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A scaling factor for output that countacts + !! any internal dimesional scaling [a A-1 ~> 1] logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole !! array rather than just the computational domain. ! Local variables @@ -62,7 +63,7 @@ subroutine myStats(array, missing, G, k, mesg, scale, full_halo) logical :: found character(len=120) :: lMesg - scl = 1.0 ; if (present(scale)) scl = scale + scl = 1.0 ; if (present(unscale)) scl = unscale minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -557,7 +558,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) @@ -585,7 +586,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -602,7 +603,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) if (debug) then - call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -874,7 +875,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif tr_out(:,:) = 0.0 @@ -902,7 +903,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -921,7 +922,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) -! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) ! endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) From c4a72dfb0535b13bc995ddd7bb560dc4d268bb81 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 8 Jun 2024 22:51:20 -0400 Subject: [PATCH 039/128] +Add a better variant of add_LOTW_BBL_diffusivity Added a refactored version of add_LOTW_BBL_diffusivity that is more accurate by avoiding a subtraction of two large numbers to determine the distance from the surface and more reproducible by avoiding the use of the Fortran sum function. This new version of the code is mathematically equivalent to the original, and it is selected by setting the new runtime parameter LOTW_BBL_ANSWER_DATE to be greater than 20240630. This probably could have been done reusing the existing parameter SET_DIFF_ANSWER_DATE, but this would have meant answer changes for some cases that set this to a high value. By default the original code is used, but the default should be changed later to follow the value of DEFAULT_ANSWER_DATE. By default, all answers are bitwise identical but there is a new runtime parameter in some cases. --- .../vertical/MOM_set_diffusivity.F90 | 34 ++++++++++++++++--- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index ef2e4ed5f6..d78b675c1a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -157,7 +157,12 @@ module MOM_set_diffusivity integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the !! end of 2018, while higher values use updated and more robust forms - !! of the same expressions. + !! of the same expressions. Values above 20240630 use more accurate + !! expressions for cases where USE_LOTW_BBL_DIFFUSIVITY is true. + integer :: LOTW_BBL_answer_date !< The vintage of the order of arithmetic and expressions + !! in the LOTW_BBL calculations. Values below 20240630 recover the + !! original answers, while higher values use more accurate expressions. + !! This only applies when USE_LOTW_BBL_DIFFUSIVITY is true. character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module @@ -1426,6 +1431,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo ! Local variables real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: dz_above(SZK_(GV)+1) ! Distance from each interface to the surface [Z ~> m] real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] @@ -1500,7 +1506,15 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + if (CS%LOTW_BBL_answer_date > 20240630) then + dz_above(1) = GV%dz_subroundoff ! This could perhaps be 0 instead. + do K=2,GV%ke+1 + dz_above(K) = dz_above(K-1) + dz(i,k-1) + enddo + total_depth = dz_above(GV%ke+1) + else + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + endif ustar_D = ustar * total_depth h_bot = 0. z_bot = 0. @@ -1525,7 +1539,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. - D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. + if (CS%LOTW_BBL_answer_date > 20240630) then + D_minus_z = dz_above(K) + else + D_minus_z = max(total_depth - z_bot, 0.) ! Distance from the interface to the surface [Z ~> m]. + endif ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer @@ -2191,7 +2209,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the actual "//& "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) - if (CS%bottomdraglaw) then + if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& "velocity field to the bottom stress. CDRAG is only used "//& @@ -2231,6 +2249,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif + call get_param(param_file, mdl, "LOTW_BBL_ANSWER_DATE", CS%LOTW_BBL_answer_date, & + "The vintage of the order of arithmetic and expressions in the LOTW_BBL "//& + "calculations. Values below 20240630 recover the original answers, while "//& + "higher values use more accurate expressions. This only applies when "//& + "USE_LOTW_BBL_DIFFUSIVITY is true.", & + default=20190101, do_not_log=.not.CS%use_LOTW_BBL_diffusivity) + !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE. + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) From e9f59c22aed457e37a1892458fd9790f78de72cf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Jun 2024 20:15:18 -0400 Subject: [PATCH 040/128] +Add optional unscale arguments to checksums Added an optional unscale argument to 16 checksum and 9 spatial_mean or spatial_integral routines. These are synonymous with the existing optional scale arguments to these routines, and if both are provided, the new unscale arguments take precedence. All this is done to come up with a more systematic nomenclature for the various scaling and unscaling arguments, so that the factors passed to them will follow a more regular pattern. With this change, the `scale=` argument to a get_param or read_data call will take the opposite setting to the `unscale=` argument used in a checksum call. For example, for a velocity, these arguments would be `scale=US%m_s_to_L_T` and `unscale=US%L_T_to_m_s`, but the reverse values of `scale=US%L_T_to_m_s` and `unscale=US%m_s_to_L_T` would only work for inverse velocities and will therefore be very uncommon and warrant extra scrutiny. With this change, `unscale=` and `conversion=` arguments used when registering diagnostics will often take similar arguments, although the latter can also have extra factors that are unrelated to dimensional rescaling. As a test of these capabilities, these new `unscale` arguments are being used in 23 calls from the MOM_chksum_packages routines and in 76 calls to chksums or global integrals from MOM_forcing_chksum(), MOM_mech_forcing_chksum() and forcing_diagnostics(). The results are equivalent to what was generated before in cases with debugging enabled so the revised code would be exercised. All answers are bitwise identical, but there are new optional arguments to 25 publicly visible routines. --- src/core/MOM_checksum_packages.F90 | 46 ++-- src/core/MOM_forcing_type.F90 | 152 ++++++------- src/diagnostics/MOM_spatial_means.F90 | 121 +++++++--- src/framework/MOM_checksums.F90 | 311 +++++++++++++++++--------- 4 files changed, 398 insertions(+), 232 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index dc60e0888f..2eb84a1c74 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -75,10 +75,10 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy scale_vel = US%L_T_to_m_s ; if (present(vel_scale)) scale_vel = vel_scale call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=scale_vel) - call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) + omit_corners=omit_corners, unscale=scale_vel) + call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + omit_corners=omit_corners, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) end subroutine MOM_state_chksum_5arg ! ============================================================================= @@ -110,8 +110,8 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, hs = 1 ; if (present(haloshift)) hs = haloshift sym = .false. ; if (present(symmetric)) sym = symmetric call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=US%L_T_to_m_s) - call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) + omit_corners=omit_corners, unscale=US%L_T_to_m_s) + call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) end subroutine MOM_state_chksum_3arg ! ============================================================================= @@ -130,22 +130,22 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift, omit_corners) hs=1 ; if (present(haloshift)) hs=haloshift if (associated(tv%T)) & - call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC) + call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt) + call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt) if (associated(tv%frazil)) & call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) + unscale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) if (associated(tv%salt_deficit)) & call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%S_to_ppt*US%RZ_to_kg_m2) + unscale=US%S_to_ppt*US%RZ_to_kg_m2) if (associated(tv%varT)) & - call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC**2) + call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC**2) if (associated(tv%varS)) & - call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt**2) + call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt**2) if (associated(tv%covarTS)) & call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, omit_corners=omit_corners, & - scale=US%S_to_ppt*US%C_to_degC) + unscale=US%S_to_ppt*US%C_to_degC) end subroutine MOM_thermo_chksum @@ -170,18 +170,18 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) hs = 1 ; if (present(haloshift)) hs = haloshift if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs, & - scale=US%C_to_degC) + unscale=US%C_to_degC) if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs, & - scale=US%S_to_ppt) + unscale=US%S_to_ppt) if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, & - haloshift=hs, scale=US%Z_to_m) + haloshift=hs, unscale=US%Z_to_m) if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & - scale=US%Z_to_m) + unscale=US%Z_to_m) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & - haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + haloshift=hs, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) end subroutine MOM_surface_chksum @@ -232,14 +232,14 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. - call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) if (present(pbce)) & - call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, scale=GV%m_to_H*US%L_T_to_m_s**2) + call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, unscale=GV%m_to_H*US%L_T_to_m_s**2) if (present(u_accel_bt) .and. present(v_accel_bt)) & call uvchksum(mesg//" [uv]_accel_bt", u_accel_bt, v_accel_bt, G%HI,haloshift=0, symmetric=sym, & - scale=US%L_T2_to_m_s2) + unscale=US%L_T2_to_m_s2) end subroutine MOM_accel_chksum ! ============================================================================= diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 83b4ea17cd..4ceb14fe11 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1262,89 +1262,89 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(fluxes%ustar)) & - call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%tau_mag)) & - call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa) if (associated(fluxes%buoy)) & - call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & - call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dir)) & - call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%lw)) & - call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent)) & - call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_evap_diag)) & call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_fprec_diag)) & call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_frunoff_diag)) & call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & - call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & - call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(fluxes%u10_sqr)) & - call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) + call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**2) if (associated(fluxes%ice_fraction)) & call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, scale=US%RZ3_T3_to_W_m2) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, unscale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_lprec)) & call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_fprec)) & call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_cond)) & call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_evap)) & call hchksum(fluxes%heat_content_evap, mesg//" fluxes%heat_content_evap", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massout)) & call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massin)) & call hchksum(fluxes%heat_content_massin, mesg//" fluxes%heat_content_massin", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. @@ -1364,17 +1364,17 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%RLZ_T2_to_Pa) + haloshift=hshift, symmetric=.true., unscale=US%RLZ_T2_to_Pa) if (associated(forces%p_surf)) & - call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(forces%ustar)) & - call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(forces%tau_mag)) & - call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) end subroutine MOM_mech_forcing_chksum @@ -2657,7 +2657,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then @@ -2684,7 +2684,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif @@ -2716,7 +2716,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif @@ -2727,7 +2727,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then - total_transport = global_area_integral(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%evap, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then @@ -2741,7 +2741,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(res, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_precip, total_transport, diag) endif if (handles%id_precip_ga > 0) then @@ -2753,7 +2753,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then - total_transport = global_area_integral(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%lprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then @@ -2765,7 +2765,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then - total_transport = global_area_integral(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%fprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then @@ -2777,7 +2777,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then - total_transport = global_area_integral(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%vprec, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then @@ -2789,7 +2789,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then - total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%lrunoff, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lrunoff, total_transport, diag) endif endif @@ -2797,7 +2797,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then - total_transport = global_area_integral(fluxes%frunoff, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%frunoff, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_frunoff, total_transport, diag) endif endif @@ -2805,7 +2805,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%RZ_T_to_kg_m2s) + total_transport = global_area_integral(fluxes%seaice_melt, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_seaice_melt, total_transport, diag) endif endif @@ -2815,63 +2815,63 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then - total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) endif if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then - total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_frunoff, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then - total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_lprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_lprec, total_transport, diag) endif if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then - total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_fprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then - total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_vprec, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_vprec, total_transport, diag) endif if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then - total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_cond, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_cond, total_transport, diag) endif if ((handles%id_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) & call post_data(handles%id_heat_content_evap, fluxes%heat_content_evap, diag) if ((handles%id_total_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) then - total_transport = global_area_integral(fluxes%heat_content_evap, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_evap, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_evap, total_transport, diag) endif if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then - total_transport = global_area_integral(fluxes%heat_content_massout, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_massout, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massout, total_transport, diag) endif if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then - total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_massin, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif @@ -2887,7 +2887,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif if (handles%id_net_heat_coupler_ga > 0) then @@ -2930,7 +2930,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then @@ -2956,7 +2956,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif endif @@ -2995,7 +2995,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 - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(res, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_LwLatSens, total_transport, diag) endif @@ -3020,7 +3020,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_sw_nir, fluxes%sw_nir_dir+fluxes%sw_nir_dif, diag) endif if ((handles%id_total_sw > 0) .and. associated(fluxes%sw)) then - total_transport = global_area_integral(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%sw, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sw, total_transport, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then @@ -3032,7 +3032,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lw, fluxes%lw, diag) endif if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then - total_transport = global_area_integral(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%lw, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lw, total_transport, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then @@ -3044,7 +3044,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat, fluxes%latent, diag) endif if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then - total_transport = global_area_integral(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat, total_transport, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then @@ -3056,7 +3056,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_evap, fluxes%latent_evap_diag, diag) endif if ((handles%id_total_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then - total_transport = global_area_integral(fluxes%latent_evap_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_evap_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_evap, total_transport, diag) endif @@ -3064,7 +3064,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_fprec, fluxes%latent_fprec_diag, diag) endif if ((handles%id_total_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then - total_transport = global_area_integral(fluxes%latent_fprec_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_fprec_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_fprec, total_transport, diag) endif @@ -3072,7 +3072,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then - total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif @@ -3085,12 +3085,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then - total_transport = global_area_integral(fluxes%seaice_melt_heat, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%seaice_melt_heat, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) endif if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then - total_transport = global_area_integral(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%sens, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sens, total_transport, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then @@ -3103,7 +3103,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then - total_transport = global_area_integral(fluxes%heat_added, G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_added, G, unscale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_added, total_transport, diag) endif @@ -3113,21 +3113,21 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & call post_data(handles%id_saltflux, fluxes%salt_flux, diag) if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltflux, total_transport, diag) endif if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxAdded, total_transport, diag) endif if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=US%RZ_T_to_kg_m2s) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, unscale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 0d656edf6d..c5def4fb28 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -32,7 +32,7 @@ module MOM_spatial_means contains !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var, G, scale, tmp_scale) +function global_area_mean(var, G, scale, tmp_scale, unscale) 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 in !! arbitrary, possibly rescaled units [A ~> a] @@ -41,6 +41,11 @@ function global_area_mean(var, G, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable !! that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_area_mean ! The mean of the variable in arbitrary unscaled units [a] or scaled units [A ~> a] ! Local variables @@ -53,7 +58,9 @@ function global_area_mean(var, G, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec 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 + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie @@ -148,7 +155,7 @@ 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, tmp_scale) +function global_area_integral(var, G, scale, area, tmp_scale, unscale) 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 in !! arbitrary, possibly rescaled units [A ~> a] @@ -159,6 +166,11 @@ function global_area_integral(var, G, scale, area, tmp_scale) !! 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 [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_area_integral !< The returned area integral, usually in the units of var times an area, !! [a m2] or [A m2 ~> a m2] depending on which optional arguments are provided @@ -172,7 +184,9 @@ function global_area_integral(var, G, scale, area, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec 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 + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0. if (present(area)) then @@ -193,7 +207,7 @@ function global_area_integral(var, G, scale, area, tmp_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, tmp_scale) +function global_layer_mean(var, h, G, GV, scale, tmp_scale, unscale) 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 in @@ -204,6 +218,11 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence. real, dimension(SZK_(GV)) :: global_layer_mean !< The mean of the variable in the arbitrary scaled [A] !! or unscaled [a] units of var, depending on which optional !! arguments are provided @@ -224,7 +243,9 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale ; if (present(scale)) scalefac = scale * temp_scale + scalefac = temp_scale + if (present(unscale)) then ; scalefac = unscale * temp_scale + elseif (present(scale)) then ; scalefac = scale * temp_scale ; endif tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -243,7 +264,7 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) 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, tmp_scale) +function global_volume_mean(var, h, G, GV, scale, tmp_scale, unscale) 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)), & @@ -256,6 +277,11 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_volume_mean !< The thickness-weighted average of var in the arbitrary scaled [A] or !! unscaled [a] units of var, depending on which optional arguments are provided @@ -271,7 +297,9 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale ; if (present(scale)) scalefac = temp_scale * scale + scalefac = temp_scale + if (present(unscale)) then ; scalefac = temp_scale * unscale + elseif (present(scale)) then ; scalefac = temp_scale * scale ; endif tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -286,7 +314,7 @@ 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, tmp_scale) +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale, unscale) 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)), & @@ -301,6 +329,11 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. real :: global_mass_integral !< The mass-weighted integral of var (or 1) in !! kg times the arbitrary units of var [kg a] or [kg A ~> kg a] @@ -315,7 +348,9 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke 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 + scalefac = G%US%L_to_m**2*temp_scale + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0.0 if (present(var)) then @@ -346,7 +381,7 @@ 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) +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale, unscale) 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)), & @@ -359,6 +394,11 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] !! that converts it back to unscaled (e.g., mks) !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in !! kg times the arbitrary units of var [kg a] @@ -373,7 +413,8 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) 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 + if (present(unscale)) then ; scalefac = unscale * scalefac + elseif (present(scale)) then ; scalefac = scale * scalefac ; endif tmpForSum(:,:) = 0.0 if (present(var)) then @@ -395,7 +436,7 @@ 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. -subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale, unscale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in !! arbitrary, possibly rescaled units [A ~> a] @@ -407,14 +448,19 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] real :: mask_sum_r ! The sum of the mask values in a row [nondim] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -422,10 +468,13 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -479,7 +528,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + if (rescale /= 1.0) then ; do j=js,je ; i_mean(j) = rescale*i_mean(j) ; enddo ; endif deallocate(asum) @@ -487,7 +536,7 @@ end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale, unscale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in !! arbitrary, possibly rescaled units [A ~> a] @@ -499,6 +548,11 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the @@ -506,18 +560,21 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] real :: mask_sum_r ! The sum of the mask values in a row [nondim] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -571,14 +628,14 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + if (rescale /= 1.0) then ; do i=is,ie ; j_mean(i) = rescale*j_mean(i) ; enddo ; endif deallocate(asum) end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour -subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) +subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) type(ocean_grid_type), intent(in) :: G !< Grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in !! arbitrary, possibly rescaled units [A ~> a] @@ -586,6 +643,11 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable [a A-1 ~> 1] !! that converts it back to unscaled (e.g., mks) !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here unit_scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums @@ -598,7 +660,10 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real :: posScale, negScale ! The scaling factor to apply to positive or negative values [nondim] integer :: i,j - scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(unit_scale)) then ; scalefac = unit_scale ; endif + I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac ! areaXposVals(:,:) = 0. ! This zeros out halo points. diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 00e4ba4918..4e349e0fb7 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -102,13 +102,17 @@ module MOM_checksums contains !> Checksum a scalar field (consistent with array checksums) -subroutine chksum0(scalar, mesg, scale, logunit) +subroutine chksum0(scalar, mesg, scale, logunit, unscale) real, intent(in) :: scalar !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] character(len=*), intent(in) :: mesg !< An identifying message real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -122,7 +126,10 @@ subroutine chksum0(scalar, mesg, scale, logunit) if (checkForNaNs .and. is_NaN(scalar)) & call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then @@ -141,13 +148,17 @@ end subroutine chksum0 !> Checksum a 1d array (typically a column). -subroutine zchksum(array, mesg, scale, logunit) +subroutine zchksum(array, mesg, scale, logunit, unscale) real, dimension(:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] character(len=*), intent(in) :: mesg !< An identifying message real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -165,14 +176,17 @@ subroutine zchksum(array, mesg, scale, logunit) call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate(rescaled_array(LBOUND(array,1):UBOUND(array,1)), source=0.0) do k=1, size(array, 1) - rescaled_array(k) = scale * array(k) + rescaled_array(k) = scaling * array(k) enddo call subStats(rescaled_array, aMean, aMin, aMax) @@ -192,15 +206,15 @@ subroutine zchksum(array, mesg, scale, logunit) contains - integer function subchk(array, scale) + integer function subchk(array, unscale) real, dimension(:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] - real, intent(in) :: scale !< A factor to convert this array back to unscaled units - !! for checksums and output [a A-1 ~> 1] + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: k, bc subchk = 0 do k=LBOUND(array, 1), UBOUND(array, 1) - bc = bitcount(abs(scale * array(k))) + bc = bitcount(abs(unscale * array(k))) subchk = subchk + bc enddo subchk=mod(subchk, bc_modulus) @@ -228,7 +242,7 @@ end subroutine zchksum !> Checksums on a pair of 2d arrays staggered at tracer points. subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -242,6 +256,10 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -271,18 +289,18 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_h_2d !> Checksums on a pair of 3d arrays staggered at tracer points. subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -296,6 +314,11 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -325,19 +348,19 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif ! NOTE: automatic deallocation of array[AB]_in end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. -subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) +subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid in !! arbitrary, possibly rescaled units [A ~> a] @@ -347,6 +370,10 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -383,15 +410,18 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j) = scale*array(i,j) + rescaled_array(i,j) = scaling*array(i,j) enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) deallocate(rescaled_array) @@ -445,18 +475,18 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j))) + bc = bitcount(abs(unscale*array(i,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -491,7 +521,7 @@ end subroutine chksum_h_2d !> Checksums on a pair of 2d arrays staggered at q-points. subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -507,6 +537,10 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: sym logical :: vector_pair @@ -540,21 +574,21 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) - call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_2d !> Checksums on a pair of 3d arrays staggered at q-points. subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed in @@ -570,7 +604,11 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector - + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -600,20 +638,20 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) - call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_3d !> Checksums a 2d array staggered at corner points. subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:), & target, intent(in) :: array_m !< The array to be checksummed in @@ -626,6 +664,10 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -662,19 +704,22 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J) = scale*array(I,J) + rescaled_array(I,J) = scaling*array(I,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -736,19 +781,19 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J))) + bc = bitcount(abs(unscale*array(I,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -787,7 +832,7 @@ end subroutine chksum_B_2d !> Checksums a pair of 2d velocity arrays staggered at C-grid locations subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed in @@ -803,6 +848,11 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -832,20 +882,20 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_2d !> Checksums a pair of 3d velocity arrays staggered at C-grid locations subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed in @@ -861,6 +911,11 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -890,20 +945,20 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -915,6 +970,10 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -941,7 +1000,8 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) @@ -959,18 +1019,21 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j) = scale*array(I,j) + rescaled_array(I,j) = scaling*array(I,j) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1039,19 +1102,19 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j))) + bc = bitcount(abs(unscale*array(I,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -1089,7 +1152,7 @@ end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1101,6 +1164,10 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1127,7 +1194,8 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) @@ -1145,18 +1213,21 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J) = scale*array(i,J) + rescaled_array(i,J) = scaling*array(i,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1225,19 +1296,19 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J))) + bc = bitcount(abs(unscale*array(i,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -1274,7 +1345,7 @@ end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) +subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1284,6 +1355,10 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1320,16 +1395,19 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j,k) = scale*array(i,j,k) + rescaled_array(i,j,k) = scaling*array(i,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) @@ -1385,18 +1463,18 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j,k))) + bc = bitcount(abs(unscale*array(i,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1431,7 +1509,7 @@ end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1443,6 +1521,10 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1479,20 +1561,23 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J,k) = scale*array(I,J,k) + rescaled_array(I,J,k) = scaling*array(I,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1560,19 +1645,19 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J,k))) + bc = bitcount(abs(unscale*array(I,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1610,7 +1695,7 @@ end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1622,6 +1707,10 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1648,7 +1737,8 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) @@ -1666,19 +1756,22 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j,k) = scale*array(I,j,k) + rescaled_array(I,j,k) = scaling*array(I,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1746,19 +1839,19 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j,k))) + bc = bitcount(abs(unscale*array(I,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1796,7 +1889,7 @@ end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] @@ -1808,6 +1901,10 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units @@ -1834,7 +1931,8 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) @@ -1852,19 +1950,22 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J,k) = scale*array(i,J,k) + rescaled_array(i,J,k) = scaling*array(i,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1932,19 +2033,19 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A factor to convert this array back to unscaled units + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J,k))) + bc = bitcount(abs(unscale*array(i,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) From 2f2b7905c08e95a729d3dd3f8b02e0a0bed10602 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 6 Jun 2024 08:30:53 -0400 Subject: [PATCH 041/128] +Add optional unscale arguments to MOM_write_field Added an optional unscale argument to 10 routines under the overloaded MOM_write_field interface, mirroring the recent additions of unscale arguments to the various chksum routines. These new unscale arguments are synonymous with the existing optional scale arguments to these routines, and if both are provided, the new unscale arguments take precedence. A total of 26 MOM_write_field calls in save_restart, write_depth_list, write_Hybgen_coord_file, write_vertgrid_file and write_ocean_geometry_file were modified to replace a scale argument with the new unscale argument. All answers are bitwise identical, but there are new optional arguments to 10 publicly visible routines. --- src/ALE/MOM_hybgen_regrid.F90 | 6 +- src/diagnostics/MOM_sum_output.F90 | 6 +- src/framework/MOM_io.F90 | 181 +++++++++++++----- src/framework/MOM_restart.F90 | 10 +- .../MOM_coord_initialization.F90 | 4 +- .../MOM_shared_initialization.F90 | 42 ++-- .../vertical/MOM_bkgnd_mixing.F90 | 8 +- 7 files changed, 168 insertions(+), 89 deletions(-) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 491693549f..8c0733be78 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -258,9 +258,9 @@ subroutine write_Hybgen_coord_file(GV, CS, filepath) call create_MOM_file(IO_handle, trim(filepath), vars, 3, fields, & SINGLE_FILE, GV=GV) - call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) - call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) - call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) + call MOM_write_field(IO_handle, fields(1), CS%dp0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, unscale=CS%Rho_coord_scale) call IO_handle%close() end subroutine write_Hybgen_coord_file diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index fb95b79a91..edb66d225c 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1269,9 +1269,9 @@ subroutine write_depth_list(G, US, DL, filename) call create_MOM_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, & extra_axes=extra_axes, global_atts=global_atts) - call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) + call MOM_write_field(IO_handle, fields(1), DL%depth, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, unscale=US%Z_to_m*US%L_to_m**2) call delete_axis_info(extra_axes) call delete_attribute_info(global_atts) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 27d244b226..8ee192323a 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -2504,7 +2504,7 @@ end subroutine MOM_read_vector_3d !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2516,7 +2516,13 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2524,6 +2530,7 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2541,7 +2548,7 @@ end subroutine MOM_write_field_legacy_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2553,8 +2560,13 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2562,6 +2574,7 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2579,7 +2592,7 @@ end subroutine MOM_write_field_legacy_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition @@ -2591,8 +2604,13 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [a] or ! rescaled [A ~> a] then [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] @@ -2600,6 +2618,7 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & @@ -2616,7 +2635,7 @@ end subroutine MOM_write_field_legacy_2d !> Write a 1d field to an output file -subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] @@ -2625,13 +2644,19 @@ subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_va real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - + ! Local variables real, dimension(:), allocatable :: array ! A rescaled copy of field [a] real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if (scale_fac == 1.0) then call write_field(IO_handle, field_md, field, tstamp=tstamp) @@ -2648,7 +2673,7 @@ end subroutine MOM_write_field_legacy_1d !> Write a 0d field to an output file -subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] @@ -2657,11 +2682,21 @@ subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_va real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before !! it is written [a A-1 ~> 1], for example to convert it !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] real :: scaled_val ! A rescaled copy of field [a] - scaled_val = field - if (present(scale)) scaled_val = scale*field + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif call write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) @@ -2670,24 +2705,32 @@ end subroutine MOM_write_field_legacy_0d !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - 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 + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2704,24 +2747,32 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - 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 + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2738,24 +2789,32 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) + fill_value, turns, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - 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 + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if ((qturns == 0) .and. (scale_fac == 1.0)) then call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & @@ -2771,20 +2830,28 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti end subroutine MOM_write_field_2d !> Write a 1d field to an output file -subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, dimension(:), allocatable :: array ! A rescaled copy of field - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, dimension(:), allocatable :: array ! A rescaled copy of field in arbtrary unscaled units [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale if (scale_fac == 1.0) then call IO_handle%write_field(field_md, field, tstamp=tstamp) @@ -2800,18 +2867,30 @@ subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, sc end subroutine MOM_write_field_1d !> Write a 0d field to an output file -subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(MOM_field), intent(in) :: field_md !< Field type with metadata - real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written - real :: scaled_val ! A rescaled copy of field + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] + real :: scaled_val ! A rescaled copy of field in arbtrary unscaled units [a] + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac - scaled_val = field - if (present(scale)) scaled_val = scale*field if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 44dee97a76..8152564b4f 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1513,19 +1513,19 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then call 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) + restart_time, unscale=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, scale=CS%restart_field(m)%conv, turns=-turns) + restart_time, unscale=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, scale=CS%restart_field(m)%conv, turns=-turns) + restart_time, unscale=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, scale=CS%restart_field(m)%conv) + restart_time, unscale=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, scale=CS%restart_field(m)%conv) + restart_time, unscale=CS%restart_field(m)%conv) endif enddo diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index bb7832525f..9acf693f5f 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -600,8 +600,8 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & SINGLE_FILE, GV=GV) - call MOM_write_field(IO_handle, fields(1), GV%Rlay, scale=US%R_to_kg_m3) - call MOM_write_field(IO_handle, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) + call MOM_write_field(IO_handle, fields(1), GV%Rlay, unscale=US%R_to_kg_m3) + call MOM_write_field(IO_handle, fields(2), GV%g_prime, unscale=US%L_T_to_m_s**2*US%m_to_Z) call IO_handle%close() diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 821232b80d..edf08da3aa 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1424,30 +1424,30 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) - call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, scale=US%s_to_T) - - call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, scale=US%L_to_m) - - call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, scale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, scale=US%L_to_m**2) - - call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, unscale=US%s_to_T) + + call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, unscale=US%L_to_m) + + call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, unscale=US%L_to_m**2) + + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, unscale=US%L_to_m) call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, unscale=US%Z_to_m) endif call IO_handle%close() diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 4c0baf3d26..64e7f17ef2 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -234,19 +234,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.16e-04, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.16e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.01e-04, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.01e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.13e-4, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=0.13e-4, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 1.0e-4, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=1.0e-4, scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & From c5e5e3057a25eadb7bb45ec92231c93ab62cec97 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 May 2024 10:28:10 -0400 Subject: [PATCH 042/128] Better error messages in interp_for_nondim_pos Cleaned up the error messages when there are fatal problems in interpolate_for_nondim_position() in the MOM_neutral_diffusion module to explicitly give an indications of all the problems. These had previously triggered fatal errors (or should have), but had less explicit or incorrect error messages in some cases, so all solutions and behavior are identical in any cases that worked previously. --- src/tracer/MOM_neutral_diffusion.F90 | 53 +++++++++++++++------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 6b60769144..051ac446db 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1574,34 +1574,39 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) character(len=120) :: mesg - if (Ppos < Pneg) then - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then - write(stderr,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos - write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=', dRhoNeg, Pneg, dRhoPos, Ppos - call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) - elseif (dRhoNeg>dRhoPos) then !### Does this duplicated test belong here? - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos') - endif - if (Ppos<=Pneg) then ! Handle vanished or inverted layers - interpolate_for_nondim_position = 0.5 - elseif ( dRhoPos - dRhoNeg > 0. ) then - interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) - elseif ( dRhoPos - dRhoNeg == 0) then - if (dRhoNeg>0.) then - interpolate_for_nondim_position = 0. - elseif (dRhoNeg<0.) then - interpolate_for_nondim_position = 1. - else ! dRhoPos = dRhoNeg = 0 + if ((Ppos > Pneg) .and. (dRhoPos - dRhoNeg >= 0. )) then + if ( dRhoPos - dRhoNeg > 0. ) then + interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) + elseif (dRhoPos - dRhoNeg == 0) then + if (dRhoNeg > 0.) then + interpolate_for_nondim_position = 0. + elseif (dRhoNeg < 0.) then + interpolate_for_nondim_position = 1. + else ! dRhoPos = dRhoNeg = 0 + interpolate_for_nondim_position = 0.5 + endif + else ! dRhoPos - dRhoNeg < 0 interpolate_for_nondim_position = 0.5 endif - else ! dRhoPos - dRhoNeg < 0 + elseif (Ppos == Pneg) then ! Handle vanished or inverted layers interpolate_for_nondim_position = 0.5 + else ! ((Ppos < Pneg) .or. (dRhoNeg > dRhoPos) ) + ! Error handling for problematic cases. It is expected that this should never occur. + write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos', dRhoNeg, Pneg, dRhoPos, Ppos + call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) + ! write(stderr,*) trim(mesg) + if ((Ppos < Pneg) .and. (dRhoNeg > dRhoPos)) then + mesg = '(Ppos < Pneg) and (dRhoNeg > dRhoPos)' + elseif (Ppos < Pneg) then + mesg = 'Ppos < Pneg' + elseif (dRhoNeg > dRhoPos) then + mesg = trim(mesg)//'; dRhoNeg > dRhoPos' + else ! This should never happen. + mesg = 'Unexpected failure.' + endif + call MOM_error(FATAL, 'interpolate_for_nondim_position: '//trim(mesg)) endif - if ( interpolate_for_nondim_position < 0. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg') - if ( interpolate_for_nondim_position > 1. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos') + end function interpolate_for_nondim_position !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns From b4c91e306ac2afd7600898baac50437bdd7c5561 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jul 2024 14:17:33 -0400 Subject: [PATCH 043/128] Correct 10 do-loop index cases Corrected the case of the do-loop index variable in 10 places in 6 files, initialized two whole diagnostic arrays to 0 instead of having shared loops initializing u- and v-point arrays, and shortened two loops initializing pressures to the size that is actually used in the corresponding equation of state calls. With these changes, there are no i- or j- loops with extents that are inconsistent with the stagger-based index case convention used throughout the MOM6 code. All answers are bitwise identical in all cases. --- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 4 +--- src/diagnostics/MOM_spatial_means.F90 | 2 +- src/initialization/MOM_state_initialization.F90 | 2 +- src/parameterizations/lateral/MOM_internal_tides.F90 | 4 ++-- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 4 ++-- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 6 +++--- src/user/RGC_initialization.F90 | 2 +- 9 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 2d463b909c..7d112de337 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2533,7 +2533,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie + do J=js-1,je ; do i=is,ie l_seg = OBC%segnum_v(i,J) if (l_seg == OBC_NONE) cycle diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index a6949e1f40..bc0a81e40e 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -395,7 +395,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,slope,l_seg) - do j=js-1,je ; do K=nz,2,-1 + do J=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e5996826e2..d5ba50e99a 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -970,9 +970,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (.not.(CS%KE_term_on .or. (CS%id_KE > 0))) return - do j=js-1,je ; do i=is-1,ie - KE_u(I,j) = 0.0 ; KE_v(i,J) = 0.0 - enddo ; enddo + KE_u(:,:) = 0. ; KE_v(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie KE(i,j,k) = ((u(I,j,k) * u(I,j,k) + u(I-1,j,k) * u(I-1,j,k)) & diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index c5def4fb28..d8a8abfd99 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -103,7 +103,7 @@ function global_area_mean_v(var, G, tmp_scale) scalefac = G%US%L_to_m**2*temp_scale tmpForSumming(:,:) = 0. - do J=js,je ; do i=is,ie + do j=js,je ; do i=is,ie 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)) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 3e71a98f55..857cad578d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2045,7 +2045,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 225781ce0c..3f67e0e2b5 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1096,7 +1096,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) cnmask(:,:) = merge(0., 1., cn(:,:) == 0.) - do j=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 ! and wgt = 1 if neighbour cn == 0 wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) @@ -1104,7 +1104,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) enddo ; enddo - do j=js-1,je ; do i=is,ie + do J=js-1,je ; do i=is,ie wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 9f0061f104..4361712dde 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -703,7 +703,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo @@ -1164,7 +1164,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d if (CS%id_lfbod > 0) call post_data(CS%id_lfbod, lf_bodner_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie h_vel = 0.5*((htot(i,j) + htot(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b811f01d94..e9d9b7f50d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -221,7 +221,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) enddo ; enddo !$OMP parallel do default(shared) - do j=js-1,je ; do I=is,ie + 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))) enddo ; enddo @@ -426,7 +426,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%MEKE_GEOMETRIC) then if (CS%MEKE_GEOM_answer_date < 20190101) then !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! This does not give bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j) + & @@ -435,7 +435,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo else !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! With the additional parentheses this gives bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*((VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)) + & diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index e21936ddb4..1570cab7d3 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -183,7 +183,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) do j=js,je call calculate_density(T(:,j,1), S(:,j,1), pres, rho(:,j), tv%eqn_of_state, EOSdom) From 12af9002e06a20866b6fcac09cee0e258a9278eb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Jun 2024 08:02:15 -0400 Subject: [PATCH 044/128] Use unscale arguments in 384 checksum calls Replaced 382 scale arguments with unscale arguments in calls to chksum routines, and did the same in another 5 calls to global_mean or global_integral routines. Also added 2 missing unscale arguments to checksums for the initial velocities, which probably had gone undetected because we usually initialize velocities to 0. All answers and diagnostic debugging output (apart from the afore noted checksums of the initial velocities in some rare case) are bitwise identical. --- src/core/MOM.F90 | 72 +++++----- src/core/MOM_barotropic.F90 | 56 ++++---- src/core/MOM_dynamics_split_RK2.F90 | 28 ++-- src/core/MOM_dynamics_split_RK2b.F90 | 26 ++-- src/core/MOM_interface_heights.F90 | 8 +- src/core/MOM_open_boundary.F90 | 10 +- src/core/MOM_variables.F90 | 10 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/framework/MOM_horizontal_regridding.F90 | 6 +- src/ice_shelf/MOM_ice_shelf.F90 | 34 ++--- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 6 +- .../MOM_fixed_initialization.F90 | 8 +- src/initialization/MOM_grid_initialize.F90 | 24 ++-- .../MOM_state_initialization.F90 | 18 +-- src/parameterizations/lateral/MOM_MEKE.F90 | 24 ++-- .../lateral/MOM_hor_visc.F90 | 18 +-- .../lateral/MOM_interface_filter.F90 | 12 +- .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 16 +-- .../lateral/MOM_mixed_layer_restrat.F90 | 47 +++---- .../lateral/MOM_thickness_diffuse.F90 | 30 ++--- .../vertical/MOM_CVMix_KPP.F90 | 22 ++-- .../vertical/MOM_CVMix_conv.F90 | 10 +- .../vertical/MOM_diabatic_driver.F90 | 124 +++++++++--------- .../vertical/MOM_internal_tide_input.F90 | 6 +- .../vertical/MOM_kappa_shear.F90 | 8 +- .../vertical/MOM_set_diffusivity.F90 | 44 +++---- .../vertical/MOM_set_viscosity.F90 | 24 ++-- .../vertical/MOM_vert_friction.F90 | 6 +- src/tracer/MOM_CFC_cap.F90 | 2 +- src/tracer/MOM_generic_tracer.F90 | 4 +- src/tracer/MOM_offline_main.F90 | 70 +++++----- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 4 +- src/tracer/pseudo_salt_tracer.F90 | 4 +- 35 files changed, 395 insertions(+), 392 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d37f265030..8f0f0e7462 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1297,7 +1297,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then - if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_MKS) + if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_MKS) if (CS%thickness_diffuse) then call cpu_clock_begin(id_clock_thick_diff) @@ -1306,7 +1306,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) - if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_MKS) + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") @@ -1327,9 +1327,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! apply the submesoscale mixed layer restratification parameterization if (CS%mixedlayer_restrat) then if (CS%debug) then - call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-mixedlayer_restrat uhtr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & @@ -1337,9 +1337,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (CS%debug) then - call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-mixedlayer_restrat [uv]htr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif endif @@ -1410,15 +1410,15 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (CS%debug) then call cpu_clock_begin(id_clock_other) - call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h,"Pre-advection h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) - if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, scale=US%S_to_ppt) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) + if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & - "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%S_to_ppt*US%RZ_to_kg_m2) + "Pre-advection salt deficit", G%HI, haloshift=0, unscale=US%S_to_ppt*US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) call cpu_clock_end(id_clock_other) endif @@ -1593,10 +1593,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_thermo) if (.not.CS%adiabatic) then if (CS%debug) then - call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) @@ -1634,8 +1634,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) - call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) - call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) + call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., unscale=US%C_to_degC) + call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., unscale=US%S_to_ppt) call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_ALE) @@ -1720,8 +1720,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug .and. CS%use_ALE_algorithm) then call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) - call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) - call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, unscale=US%S_to_ppt) call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif @@ -1734,18 +1734,18 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) if (CS%debug) then - call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Post-diabatic ", u, v, & ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & - "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + "Post-diabatic salt deficit", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) endif @@ -1765,8 +1765,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) if (CS%debug) then - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) endif ! Update derived thermodynamic quantities. @@ -3031,7 +3031,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (use_ice_shelf .and. CS%debug) then call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) - call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0,scale=US%RZ_to_kg_m2) + call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) endif call cpu_clock_end(id_clock_MOM_init) @@ -3070,8 +3070,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! \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 hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, unscale=GV%H_to_MKS) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) @@ -3128,11 +3128,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call cpu_clock_end(id_clock_pass_init) if (CS%debug) then - call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, unscale=GV%H_to_MKS) if (use_temperature) then - call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, scale=US%S_to_ppt) + call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, unscale=US%S_to_ppt) endif endif endif @@ -4130,7 +4130,7 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) heat = CS%US%Q_to_J_kg*CS%tv%C_p * & global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only, tmp_scale=CS%US%C_to_degC) if (present(salt)) & - salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, scale=CS%US%S_to_ppt) + salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, unscale=CS%US%S_to_ppt) end subroutine get_ocean_stocks diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7d112de337..a132200759 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1725,23 +1725,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug) then call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, scale=US%L_T_to_m_s) - call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_MKS) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & - CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) if (interp_eta_PF) then - call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) - call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) else - call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) - call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, unscale=GV%H_to_MKS) endif - call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & - scale=US%L_to_m**2*US%s_to_T*GV%H_to_m) + unscale=US%L_to_m**2*US%s_to_T*GV%H_to_m) if (.not. use_BT_cont) then - call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, scale=US%L_to_m*GV%H_to_m) + call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, unscale=US%L_to_m*GV%H_to_m) endif call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) @@ -1749,9 +1749,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) - call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & - scale=GV%m_to_H, scalar_pair=.true.) + unscale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) endif @@ -2324,22 +2324,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then write(mesg,'("BT vel update ",I4)') n call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) + unscale=US%L_T_to_m_s*US%s_to_T) call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & haloshift=iev-ie, scalar_pair=.true.) call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) + unscale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_to_m**2*GV%H_to_m) + unscale=US%L_to_m**2*GV%H_to_m) endif if (find_PF) then @@ -2426,10 +2426,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & - haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) + haloshift=iev-ie, unscale=US%L_to_m**2*GV%H_to_m) endif if (integral_BT_cont) then @@ -2463,8 +2463,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then write(mesg,'("BT step ",I4)') n call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) - call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_MKS) + unscale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, unscale=GV%H_to_MKS) endif if (GV%Boussinesq) then @@ -2947,8 +2947,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) CS%dtbt_max = dtbt_max if (CS%debug) then - call chksum0(CS%dtbt, "End set_dtbt dtbt", scale=US%T_to_s) - call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", scale=US%T_to_s) + call chksum0(CS%dtbt, "End set_dtbt dtbt", unscale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", unscale=US%T_to_s) endif end subroutine set_dtbt @@ -3698,9 +3698,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) scalar_pair=.true.) if (present(h_u) .and. present(h_v)) & call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & - symmetric=.true., omit_corners=.true., scale=GV%H_to_MKS, & + symmetric=.true., omit_corners=.true., unscale=GV%H_to_MKS, & scalar_pair=.true.) - call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "btcalc h",G%HI, haloshift=1, unscale=GV%H_to_MKS) endif end subroutine btcalc diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 671f707583..2296496144 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -584,7 +584,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) @@ -668,10 +668,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) @@ -685,7 +685,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! u_av <- u_av + dt_pred d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) if (CS%debug) then - call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif if (CS%fpmix) then @@ -754,12 +754,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (associated(CS%OBC)) then if (CS%debug) & - call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) if (CS%debug) & - call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) ! These should be done with a pass that excludes uh & vh. ! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) @@ -837,8 +837,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) @@ -929,10 +929,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & @@ -1158,8 +1158,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (CS%debug) then call MOM_state_chksum("Corrector ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) endif diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 9c5c248c3c..021b3ceb0e 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -600,7 +600,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) @@ -691,10 +691,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) @@ -708,7 +708,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! u_av <- u_av + dt_pred d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) if (CS%debug) then - call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif ! if (CS%fpmix) then @@ -770,12 +770,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (associated(CS%OBC)) then if (CS%debug) & - call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) if (CS%debug) & - call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) endif ! h_av = (h + hp)/2 @@ -834,8 +834,8 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, scale=GV%H_to_MKS) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) @@ -923,10 +923,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & @@ -1119,7 +1119,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%debug) then call MOM_state_chksum("Corrector ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) - ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, scale=US%L_T_to_m_s) + ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, unscale=US%L_T_to_m_s) endif if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 3891c86e3a..6e272f7b41 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -307,11 +307,11 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) tv%valid_SpV_halo = halos if (do_debug) then - call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, scale=GV%H_to_MKS) + call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, unscale=GV%H_to_MKS) if (associated(tv%p_surf)) call hchksum(tv%p_surf, "derived_thermo p_surf", G%HI, & - haloshift=halos, scale=US%RL2_T2_to_Pa) - call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) - call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) + haloshift=halos, unscale=US%RL2_T2_to_Pa) + call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, unscale=US%C_to_degC) + call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, unscale=US%S_to_ppt) endif elseif (allocated(tv%Spv_avg)) then do k=1,nz ; SpV_lay(k) = 1.0 / GV%Rlay(k) ; enddo diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3674e63c31..9b8d26cb09 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3318,22 +3318,22 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, sym = G%Domain%symmetric if (OBC%radiation_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & - haloshift=0, symmetric=sym, scale=1.0) + haloshift=0, symmetric=sym, unscale=1.0) endif if (OBC%oblique_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & - haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) endif if (OBC%ntr == 0) return if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return do m=1,OBC%ntr write(var_num,'(I3.3)') m call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & - haloshift=0, symmetric=sym, scale=1.0) + haloshift=0, symmetric=sym, unscale=1.0) enddo endif diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 37c1607826..5b7740230a 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -597,15 +597,15 @@ subroutine MOM_thermovar_chksum(mesg, tv, G, US) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(tv%T)) & - call hchksum(tv%T, mesg//" tv%T", G%HI, scale=US%C_to_degC) + call hchksum(tv%T, mesg//" tv%T", G%HI, unscale=US%C_to_degC) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" tv%S", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S, mesg//" tv%S", G%HI, unscale=US%S_to_ppt) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=US%RZ_to_kg_m2*US%S_to_ppt) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, unscale=US%RZ_to_kg_m2*US%S_to_ppt) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=US%RZ_to_kg_m2*US%C_to_degC) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, unscale=US%RZ_to_kg_m2*US%C_to_degC) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d5ba50e99a..b819c39ef1 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1375,7 +1375,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = G%mask2dT(i,j) * (ssh(i,j) + G%bathyT(i,j)) enddo ; enddo - volo = global_area_integral(work_2d, G, scale=US%Z_to_m) + volo = global_area_integral(work_2d, G, unscale=US%Z_to_m) call post_data(IDs%id_volo, volo, diag) endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 719eb7d9e4..324808e374 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -612,7 +612,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd @@ -921,7 +921,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) ! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, unscale=I_scale) ! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) ! endif @@ -930,7 +930,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a4b06b6150..eb021d8ffb 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -421,12 +421,12 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%debug) then call hchksum(fluxes_in%frac_shelf_h, "frac_shelf_h before apply melting", CS%Grid_in%HI, haloshift=0) - call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%S_to_ppt) call uvchksum("[uv]_ml before apply melting", sfc_state_in%u, sfc_state_in%v, & - CS%Grid_in%HI, haloshift=0, scale=US%L_T_to_m_s) + CS%Grid_in%HI, haloshift=0, unscale=US%L_T_to_m_s) call hchksum(sfc_state_in%ocean_mass, "ocean_mass before apply melting", CS%Grid_in%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. @@ -774,9 +774,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif endif @@ -790,9 +790,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) @@ -800,9 +800,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) 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%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, unscale=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) + unscale=US%RZ_to_kg_m2) endif update_ice_vel = .false. @@ -1119,7 +1119,7 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca if (CS%debug) then call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, CS%Grid%HI, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, & forces%frac_shelf_v, CS%Grid%HI, symmetric=.true., & scalar_pair=.true.) @@ -1218,7 +1218,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) if (CS%debug) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & - G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1263,8 +1263,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) endif ; enddo ; enddo if (CS%debug) then - call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) - call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, unscale=US%QRZ_T_to_W_m2) call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) endif @@ -1920,8 +1920,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, endif enddo ; enddo if (CS%debug) then - call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) - call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) endif @@ -1956,7 +1956,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, enddo ; enddo if (CS%debug) then - call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) endif CS%Time = Time diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 837789716b..7816df32de 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1441,8 +1441,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) if (CS%debug) then - call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) - call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" @@ -3790,7 +3790,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then - call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, unscale=US%C_to_degC) endif end subroutine ice_shelf_temp diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 322abc6d5e..10236994e0 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -101,7 +101,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) if (debug) then - call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, unscale=US%Z_to_m) call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) call uvchksum('MOM_initialize_fixed: mask2dC[uv]', G%mask2dCu, & G%mask2dCv, G%HI) @@ -157,9 +157,9 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) ! Calculate the components of grad f (beta) call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US) if (debug) then - call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T) - call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%m_to_L*US%s_to_T) - call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%m_to_L*US%s_to_T) + call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, unscale=US%s_to_T) + call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, unscale=US%m_to_L*US%s_to_T) + call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, unscale=US%m_to_L*US%s_to_T) endif call initialize_grid_rotation_angle(G, PF) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 8bea8fe6e9..ef78a896c3 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -128,28 +128,28 @@ subroutine grid_metrics_chksum(parent, G, US) halo = min(G%ied-G%iec, G%jed-G%jec, 1) call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & - haloshift=halo, scale=US%L_to_m, scalar_pair=.true.) + haloshift=halo, unscale=US%L_to_m, scalar_pair=.true.) - call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=US%L_to_m) + call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, unscale=US%L_to_m) call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & - haloshift=halo, scale=US%m_to_L, scalar_pair=.true.) + haloshift=halo, unscale=US%m_to_L, scalar_pair=.true.) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, scale=US%m_to_L) + call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, unscale=US%m_to_L) - call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, scale=US%L_to_m**2) - call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, scale=US%L_to_m**2) + call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, unscale=US%L_to_m**2) + call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, unscale=US%L_to_m**2) - call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, scale=US%m_to_L**2) - call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, scale=US%m_to_L**2) + call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, unscale=US%m_to_L**2) + call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, unscale=US%m_to_L**2) call hchksum(G%geoLonT,trim(parent)//': geoLonT',G%HI, haloshift=halo) call hchksum(G%geoLatT,trim(parent)//': geoLatT',G%HI, haloshift=halo) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 857cad578d..1467cdaaad 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -450,7 +450,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & - call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) ! Remove the mass that would be displaced by an ice shelf or inverse barometer. if (depress_sfc) then @@ -479,7 +479,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & units="s", scale=US%s_to_T, fail_if_missing=.true.) if (new_sim .and. debug) & - call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif @@ -517,7 +517,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim) call pass_vector(u, v, G%Domain) if (debug .and. new_sim) then - call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) + call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) endif ! This is the end of the block of code that might have initialized fields @@ -552,14 +552,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call pass_var(h, G%Domain) if (debug) then - call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) - if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, scale=US%C_to_degC) - if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, unscale=US%C_to_degC) + if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, unscale=US%S_to_ppt) if ( use_temperature .and. debug_layers) then ; do k=1,nz write(mesg,'("MOM_IS: T[",I2,"]")') k - call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, scale=US%C_to_degC) + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, unscale=US%C_to_degC) write(mesg,'("MOM_IS: S[",I2,"]")') k - call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, unscale=US%S_to_ppt) enddo ; endif endif @@ -2310,7 +2310,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p call MOM_error(FATAL, " initialize_oda_incupd_uv: Unable to open "//trim(filename)) allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data), source=0.0) allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data), source=0.0) - call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain,scale=US%m_s_to_L_T) + call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain, scale=US%m_s_to_L_T) call set_up_oda_incupd_vel_field(tmp_u, tmp_v, G, GV, oda_incupd_CSp) deallocate(tmp_u, tmp_v) endif diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index bfa79ba053..f3bd9e8934 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -253,17 +253,17 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h case(EKE_PROG) if (CS%debug) then if (allocated(MEKE%mom_src)) & - call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GME_snk)) & - call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GM_src)) & - call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%MEKE)) & - call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) - call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & + call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, unscale=US%L_T_to_m_s**2) + call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, unscale=US%s_to_T, & scalar_pair=.true.) call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=0, symmetric=.true., & - scale=GV%H_to_m*(US%L_to_m**2)) + unscale=GV%H_to_m*US%L_to_m**2) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping @@ -375,12 +375,12 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (CS%visc_drag) & call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & - scale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) - call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=GV%H_to_mks*US%s_to_T) + unscale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, unscale=US%RZ_to_kg_m2) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, unscale=GV%H_to_mks*US%s_to_T) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) - call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) + call hchksum(LmixScale, 'MEKE LmixScale', G%HI, unscale=US%L_to_m) endif ! Aggregate sources of MEKE (background, frictional and GM) @@ -427,7 +427,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%debug) then - call hchksum(src, "MEKE src", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(src, "MEKE src", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) endif ! Increase EKE by a full time-steps worth of source @@ -630,7 +630,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! MEKE_KH>=0 if (CS%debug) then - call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, unscale=US%L_T_to_m_s**2) endif case(EKE_FILE) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index b9e50f6b80..2a4181804b 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -594,7 +594,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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) + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, unscale=US%L_to_m**2*US%s_to_T) endif ! use_GME @@ -1996,11 +1996,11 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (CS%debug) then if (CS%Laplacian) then - call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) endif - if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) endif if (CS%id_FrictWorkIntz > 0) then @@ -2722,8 +2722,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Kh_Max_xy(I,J) = CS%bound_coef * 0.25 * Idt / denom enddo ; enddo if (CS%debug) then - call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) endif endif ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but @@ -2778,8 +2778,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom enddo ; enddo if (CS%debug) then - call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) endif endif ! Register fields for output from this module. diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index 07b698e294..ea86b80594 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -142,9 +142,9 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) if (CS%debug) then call uvchksum("Kh_[uv]", Lsm2_u, Lsm2_v, G%HI, haloshift=hs, & - scale=US%L_to_m**2, scalar_pair=.true.) - call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, scale=GV%H_to_m) - call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, scale=US%Z_to_m) + unscale=US%L_to_m**2, scalar_pair=.true.) + call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, unscale=GV%H_to_m) + call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, unscale=US%Z_to_m) endif ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v @@ -225,10 +225,10 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) if (CS%debug) then call uvchksum("interface_filter [uv]hD", uhD, vhD, & - G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2) call uvchksum("interface_filter [uv]htr", uhtr, vhtr, & - G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) - call hchksum(h, "interface_filter h", G%HI, haloshift=0, scale=GV%H_to_m) + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "interface_filter h", G%HI, haloshift=0, unscale=GV%H_to_m) endif end subroutine interface_filter diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 3f67e0e2b5..8b3a2c2dbe 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -906,7 +906,7 @@ subroutine sum_En(G, US, CS, En, label) En_sum = 0.0 do a=1,CS%nAngle - En_sum = En_sum + global_area_integral(En(:,:,a), G, scale=US%RZ3_T3_to_W_m2*US%T_to_s) + En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=US%RZ3_T3_to_W_m2*US%T_to_s) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7db0dc4e90..7315c82601 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -455,9 +455,9 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) endif if (CS%debug) then - call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, scale=US%L_T_to_m_s) + call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, unscale=US%L_T_to_m_s) call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & - scale=1.0, scalar_pair=.true.) + unscale=1.0, scalar_pair=.true.) endif end subroutine calc_resoln_function @@ -656,11 +656,11 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C if (CS%debug) then call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & - scale=US%Z_to_L, haloshift=1) + unscale=US%Z_to_L, haloshift=1) call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & - scale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) + unscale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Visbeck_coeffs_old @@ -700,9 +700,9 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative if (CS%debug) then - call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, unscale=US%Z_to_m, scalar_pair=.true.) call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + unscale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) endif !$OMP parallel do default(shared) @@ -813,7 +813,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, if (CS%debug) then call uvchksum("calc_Eady_growth_rate_2D SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Eady_growth_rate_2D diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 4361712dde..d1e0d15293 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -345,8 +345,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) @@ -362,8 +362,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, & + haloshift=1, unscale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) @@ -490,11 +491,11 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, endif if (CS%debug) then - call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=GV%H_to_m*US%s_to_T) - call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, unscale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=GV%m_to_H*US%L_T_to_m_s**2) + unscale=GV%m_to_H*US%L_T_to_m_s**2) endif ! TO DO: @@ -871,16 +872,16 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) if (CS%debug) then - call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, scale=US%Z_to_m) - call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) if (associated(bflux)) & - call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) - call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, unscale=US%Z_to_m**2*US%s_to_T**3) + call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, unscale=US%Z_to_m*US%s_to_T) call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) endif ! Apply time filter to h_MLD (to remove diurnal cycle) to obtain "little h". @@ -977,13 +978,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d endif if (CS%debug) then - call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & - G%HI, haloshift=1, scale=GV%H_to_mks) + G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & - G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) + G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, unscale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) endif ! Calculate the average density in the "mixed layer". @@ -1047,10 +1048,10 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d enddo if (CS%debug) then - call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & - scale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) - call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, scale=GV%m_to_H*US%L_T_to_m_s**2) + unscale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, unscale=GV%m_to_H*US%L_T_to_m_s**2) endif ! U - Component diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index e9d9b7f50d..d735248417 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -463,23 +463,23 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & - scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & - scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) if (Resoln_scaled) then call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & - scale=1.0, scalar_pair=.true.) + unscale=1.0, scalar_pair=.true.) endif call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) - call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, unscale=GV%H_to_m) + call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, unscale=US%Z_to_m) if (use_stored_slopes) then call uvchksum("VarMix%slope_[xy]", VarMix%slope_x, VarMix%slope_y, & - G%HI, haloshift=0, scale=US%Z_to_L) + G%HI, haloshift=0, unscale=US%Z_to_L) endif if (associated(tv%eqn_of_state)) then - call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, scale=US%C_to_degC) - call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, scale=US%S_to_ppt) + call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, unscale=US%S_to_ppt) endif endif @@ -588,10 +588,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("thickness_diffuse [uv]hD", uhD, vhD, & - G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) call uvchksum("thickness_diffuse [uv]htr", uhtr, vhtr, & - G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) - call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_m) endif end subroutine thickness_diffuse @@ -1589,11 +1589,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ; enddo ; enddo endif if (CS%debug) then - call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) - call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, scale=US%L_to_m**2*US%s_to_T, & + call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, unscale=US%L_to_m**2*US%s_to_T, & scalar_pair=.true.) - call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, scale=US%Z_to_L) - call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, scale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & + call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, unscale=US%Z_to_L) + call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, unscale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & scalar_pair=.true.) endif endif ; endif diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f480c655d7..200cb02443 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -664,11 +664,11 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & "KPP_calculate: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(h, "KPP in: h", G%HI, haloshift=0, unscale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar", G%HI, haloshift=0, unscale=US%Z_to_m*US%s_to_T) + call hchksum(buoyFlux, "KPP in: buoyFlux", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) + call hchksum(Kt, "KPP in: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif nonLocalTrans(:,:) = 0.0 @@ -920,8 +920,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & call cpu_clock_end(id_clock_KPP_calc) if (CS%debug) then - call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data @@ -1022,10 +1022,10 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, scale=US%S_to_ppt) - call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(u, "KPP in: u",G%HI,haloshift=0,scale=US%L_T_to_m_s) - call hchksum(v, "KPP in: v",G%HI,haloshift=0,scale=US%L_T_to_m_s) + call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, unscale=US%S_to_ppt) + call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(u, "KPP in: u", G%HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(v, "KPP in: v", G%HI, haloshift=0, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_KPP_compute_BLD) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 19744cb6c5..ce592a2d9c 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -281,13 +281,13 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) enddo if (CS%debug) then - ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2",G%HI,haloshift=0) + ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2", G%HI, haloshift=0, unscale=US%s_to_T**2) ! if (CS%id_kd_conv > 0) & - ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) ! if (CS%id_kv_conv > 0) & - ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 89ed3bada9..6d8afa1493 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -648,7 +648,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately @@ -669,8 +669,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%debug) then - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif call cpu_clock_begin(id_clock_kpp) @@ -727,12 +727,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -802,7 +802,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -828,19 +828,19 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_mks) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%degC_to_C) + unscale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%ppt_to_S) - call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, scale=GV%H_to_mks) - call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, scale=US%C_to_degC) - call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, scale=US%S_to_ppt) + unscale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, unscale=US%S_to_ppt) call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & - scale=US%Z_to_m**2*US%s_to_T**3) + unscale=US%Z_to_m**2*US%s_to_T**3) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -877,9 +877,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else @@ -922,8 +922,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1255,7 +1255,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. @@ -1274,8 +1274,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, endif if (CS%debug) then - call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then @@ -1322,12 +1322,12 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -1377,14 +1377,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%degC_to_C) + unscale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & - scale=US%kg_m3_to_R*US%ppt_to_S) + unscale=US%kg_m3_to_R*US%ppt_to_S) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1412,9 +1412,9 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else @@ -1449,8 +1449,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1844,8 +1844,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, US, eaml, ebml) if (CS%debug) then - call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_MKS) - call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_MKS) + call hchksum(eaml, "after find_uv_at_h eaml", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebml, "after find_uv_at_h ebml", G%HI, unscale=GV%H_to_MKS) endif else call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1883,8 +1883,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif @@ -1959,8 +1959,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif endif ! endif for KPP @@ -1973,9 +1973,9 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_kpp) if (CS%debug) then call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & - scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & - scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif @@ -2032,8 +2032,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -2188,8 +2188,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif endif @@ -2234,8 +2234,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) then if (CS%debug) then - call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -2282,8 +2282,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G, US) - call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "after mixed layer ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after mixed layer eb", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_remap) @@ -2473,8 +2473,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e ! mixed layer turbulence is applied elsewhere. if (CS%use_bulkmixedlayer) then if (CS%debug) then - call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "before net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif !$OMP parallel do default(shared) private(net_ent) do j=js,je @@ -2485,8 +2485,8 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo enddo if (CS%debug) then - call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "after net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif endif @@ -2517,9 +2517,9 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e ! or enters the ocean with the surface velocity. if (CS%debug) then call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_MKS) - call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_MKS) - call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_MKS) + call hchksum(ea, "before u/v tridiag ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before u/v tridiag eb", G%HI, unscale=GV%H_to_MKS) + call hchksum(hold, "before u/v tridiag hold", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7280106125..aa02a42ea9 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -179,9 +179,9 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) endif if (CS%debug) then - call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & - scale=US%RZ3_T3_to_W_m2) + call hchksum(N2_bot, "N2_bot", G%HI, haloshift=0, unscale=US%s_to_T**2) + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input", G%HI, haloshift=0, & + unscale=US%RZ3_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index dac8508b4d..f553108ac0 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -337,8 +337,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) @@ -621,8 +621,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ enddo ! end of J-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index d78b675c1a..754d2c4b8e 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -348,7 +348,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%useKappaShear) then if (CS%debug) then - call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then @@ -359,18 +359,18 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=GV%HZ_T_to_m2_s) - call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif else ! Changes: visc%Kd_shear ; Sets: visc%Kv_shear and visc%TKE_turb call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif endif call cpu_clock_end(id_clock_kappaShear) @@ -379,8 +379,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled @@ -389,15 +389,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Smooth the properties through massless layers. if (use_EOS) then if (CS%debug) then - call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) - call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) - call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "before vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) if (CS%debug) then - call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) - call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) - call hchksum(h, "after vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "after vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif endif @@ -596,30 +596,30 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) - if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then - call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, symmetric=.true., scale=GV%HZ_T_to_m2_s, & + haloshift=0, symmetric=.true., unscale=GV%HZ_T_to_m2_s, & scalar_pair=.true.) endif if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) then call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, symmetric=.true., scale=US%Z_to_m, & + G%HI, haloshift=0, symmetric=.true., unscale=US%Z_to_m, & scalar_pair=.true.) endif if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, & - symmetric=.true., scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + symmetric=.true., unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) endif endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e59e5d99aa..88845a390f 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -321,16 +321,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (.not.CS%bottomdraglaw) return if (CS%debug) then - call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) - call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) - if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, scale=US%S_to_ppt) + call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, unscale=GV%H_to_m) + if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (allocated(tv%SpV_avg)) & - call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, scale=US%kg_m3_to_R) + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, unscale=US%kg_m3_to_R) if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & - haloshift=1, omit_corners=.true., scale=US%kg_m3_to_R) - if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) + haloshift=1, omit_corners=.true., unscale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%S_to_ppt) endif use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS @@ -1088,13 +1090,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%debug) then if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, & - scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) + haloshift=0, unscale=GV%HZ_T_to_m2_s, scalar_pair=.true.) if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + G%HI, haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif end subroutine set_viscous_BBL diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c26ee4ac75..95856f013e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1886,12 +1886,12 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & - scale=GV%H_to_m, scalar_pair=.true.) + unscale=GV%H_to_m, scalar_pair=.true.) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & - scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & - haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index ef11739f33..fe20daaefd 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -565,7 +565,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US if (CS%debug) then do m=1,NTR call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & - scale=US%RZ_T_to_kg_m2s) + unscale=US%RZ_T_to_kg_m2s) enddo endif diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 6168ec1d70..5591e74d97 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -570,7 +570,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, surface_field(i,j) = tv%S(i,j,1) dz_ml(i,j) = US%Z_to_m * Hml(i,j) enddo ; enddo - sosga = global_area_mean(surface_field, G, scale=US%S_to_ppt) + sosga = global_area_mean(surface_field, G, unscale=US%S_to_ppt) ! !Calculate tendencies (i.e., field changes at dt) from the sources / sinks @@ -1003,7 +1003,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) dzt(:,:,:) = GV%H_to_m * h(:,:,:) - sosga = global_area_mean(sfc_state%SSS, G, scale=G%US%S_to_ppt) + sosga = global_area_mean(sfc_state%SSS, G, unscale=G%US%S_to_ppt) if ((G%US%C_to_degC == 1.0) .and. (G%US%S_to_ppt == 1.0)) then call generic_tracer_coupler_set(sfc_state%tr_fields, & diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b31ebba7c8..f772e0bc8a 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -306,8 +306,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_pre, "h_pre before transport", G%HI, scale=GV%H_to_MKS) - call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h_pre before transport", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) endif tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) if (CS%print_adv_offline) then @@ -325,8 +325,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_vol, "h_vol before advect", G%HI, scale=HL2_to_kg_scale) - call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_vol, "h_vol before advect", G%HI, unscale=HL2_to_kg_scale) + call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) write(debug_msg, '(A,I4.4)') 'Before advect ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg) endif @@ -347,7 +347,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C ! Do ALE remapping/regridding to allow for more advection to occur in the next iteration call pass_var(h_new,G%Domain) if (CS%debug) then - call hchksum(h_new,"h_new before ALE", G%HI, scale=GV%H_to_MKS) + call hchksum(h_new,"h_new before ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'Before ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -373,7 +373,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call cpu_clock_end(id_clock_ALE) if (CS%debug) then - call hchksum(h_new, "h_new after ALE", G%HI, scale=GV%H_to_MKS) + call hchksum(h_new, "h_new after ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'After ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -415,8 +415,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call hchksum(h_pre, "h after offline_advection_ale", G%HI, scale=GV%H_to_MKS) - call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h after offline_advection_ale", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -501,7 +501,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%debug) then call MOM_tracer_chksum("Before upwards redistribute ", CS%tracer_Reg, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -542,7 +542,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%debug) then call MOM_tracer_chksum("Before barotropic redistribute ", CS%tracer_Reg, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -602,8 +602,8 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%id_vhr>0) call post_data(CS%id_vhr, vhtr, CS%diag) if (CS%debug) then - call hchksum(h_pre, "h_pre after redistribute", G%HI, scale=GV%H_to_MKS) - call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call hchksum(h_pre, "h_pre after redistribute", G%HI, unscale=GV%H_to_MKS) + call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg) endif @@ -685,9 +685,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p call MOM_mesg("Applying tracer source, sinks, and vertical mixing") if (CS%debug) then - call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -751,9 +751,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p endif if (CS%debug) then - call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) - call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("After offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -794,7 +794,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) enddo ; enddo if (CS%debug) then - call hchksum(h, "h before fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h before fluxes into ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg) endif do m = 1,CS%tracer_reg%ntr @@ -804,7 +804,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt=update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h after fluxes into ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg) endif @@ -833,7 +833,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) call MOM_error(WARNING, "Negative freshwater fluxes with non-zero tracer concentration not supported yet") if (CS%debug) then - call hchksum(h, "h before fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h before fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif do m = 1, CS%tracer_reg%ntr @@ -843,7 +843,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call hchksum(h, "h after fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif @@ -1041,10 +1041,10 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr before update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, scale=GV%H_to_MKS) - call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, unscale=US%S_to_ppt) endif ! Store a copy of the layer thicknesses before ALE regrid/remap @@ -1063,9 +1063,9 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) endif if (CS%debug) then call uvchksum("[uv]h after update offline from files and arrays", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, unscale=US%S_to_ppt) endif ! If using an ALE-dependent vertical coordinate, fields will need to be remapped @@ -1083,8 +1083,8 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%id_h_regrid>0) call post_data(CS%id_h_regrid, h, CS%diag) if (CS%debug) then call uvchksum("[uv]htr after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, scale=GV%H_to_MKS) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, unscale=GV%H_to_MKS) endif endif @@ -1131,10 +1131,10 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr after update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & - scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, scale=GV%H_to_MKS) - call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, scale=US%C_to_degC) - call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, scale=US%S_to_ppt) + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, unscale=US%S_to_ppt) endif call callTree_leave("update_offline_fields") diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 2b1530e94d..5538e210da 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -660,7 +660,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**2, & scalar_pair=.true.) endif diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 0a5a8d4efd..835b93bb82 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -760,7 +760,7 @@ subroutine tracer_array_chksum(mesg, Tr, ntr, G) integer :: m do m=1,ntr - call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, scale=Tr(m)%conc_scale) + call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, unscale=Tr(m)%conc_scale) enddo end subroutine tracer_array_chksum @@ -776,7 +776,7 @@ subroutine tracer_Reg_chksum(mesg, Reg, G) if (.not.associated(Reg)) return do m=1,Reg%ntr - call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, scale=Reg%Tr(m)%conc_scale) + call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, unscale=Reg%Tr(m)%conc_scale) enddo end subroutine tracer_Reg_chksum diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index ade36bad19..b737dba5b7 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -214,7 +214,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G if (.not.associated(CS%ps)) return if (debug) then - call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) endif @@ -267,7 +267,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G endif if (debug) then - call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps, "pseudo_salt post pseudo-salt vertdiff", G%HI) endif From 2c1a9d32fce72828b7091e6f623c0ec20069e637 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 12 Jul 2024 13:17:32 -0400 Subject: [PATCH 045/128] +Add and use query_debugging_checks Added the new function query_debugging_checks to the MOM_debugging module to return flags indicating what types of debugging are enabled, including checksums or redundant value checks. This new routine is used to allow for the redundant value checks in various step_MOM routines to be enabled or disabled at run-time when debugging is on overall (by setting DEBUG = True). For cases with inconsistent redundant points, this change allows for a reduction in the volume of debugging information sent to stdout from multiple PEs (in an arbitrary order), while for cases without inconsistent redundant points this change will allow for faster debugging with checksums alone. All answers are bitwise identical, but there is a new publicly visible routine. --- src/core/MOM.F90 | 24 ++++++++++----- src/core/MOM_dynamics_split_RK2.F90 | 44 ++++++++++++++++++---------- src/core/MOM_dynamics_split_RK2b.F90 | 44 ++++++++++++++++++---------- src/diagnostics/MOM_debugging.F90 | 13 ++++++++ 4 files changed, 86 insertions(+), 39 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8f0f0e7462..8b34b3e6a3 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -6,7 +6,7 @@ module MOM ! Infrastructure modules use MOM_array_transform, only : rotate_array, rotate_vector use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum -use MOM_debugging, only : check_redundant +use MOM_debugging, only : check_redundant, query_debugging_checks use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum use MOM_coms, only : num_PEs @@ -555,6 +555,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties ! can use nonblocking halo updates logical :: cycle_start ! If true, do calculations that are only done at the start of @@ -610,6 +611,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call cpu_clock_begin(id_clock_other) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV, US) endif @@ -788,9 +790,11 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%debug) then if (cycle_start) & call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US) - if (cycle_start) call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) + if (cycle_start .and. debug_redundant) & + call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) - if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G, & + if (do_dyn .and. debug_redundant) & + call check_redundant("Before steps ", forces%taux, forces%tauy, G, & unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif call cpu_clock_end(id_clock_other) @@ -1537,6 +1541,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! velocity points [H ~> m or kg m-2] logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. logical :: showCallTree type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h integer :: dynamics_stencil ! The computational stencil for the calculations @@ -1547,6 +1552,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") + if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) use_ice_shelf = .false. if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. @@ -1599,7 +1605,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) - call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif @@ -1636,7 +1643,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., unscale=US%C_to_degC) call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., unscale=US%S_to_ppt) - call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_ALE) @@ -1722,7 +1730,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, unscale=US%C_to_degC) call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, unscale=US%S_to_ppt) - call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif ! Whenever thickness changes let the diag manager know, target grids @@ -1747,7 +1756,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & "Post-diabatic salt deficit", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) - call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + if (debug_redundant) & + call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) endif call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 2296496144..b545d99daa 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -22,7 +22,7 @@ module MOM_dynamics_split_RK2 use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks 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 @@ -387,6 +387,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. @@ -419,9 +420,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) - call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -562,10 +566,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif call cpu_clock_begin(id_clock_vertvisc) @@ -677,8 +683,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! up <- up + dt_pred d/dz visc d/dz up @@ -840,8 +848,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! diffu = horizontal viscosity terms (u_av) @@ -882,10 +892,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -909,7 +921,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_btstep) if (showCallTree) call callTree_leave("btstep()") - if (CS%debug) then + if (CS%debug .and. debug_redundant) then call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 021b3ceb0e..c6642506f9 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -24,7 +24,7 @@ module MOM_dynamics_split_RK2b use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks 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 @@ -386,6 +386,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. @@ -415,9 +416,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Start predictor ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) - call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -578,10 +582,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif call cpu_clock_begin(id_clock_vertvisc) @@ -700,8 +706,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! up <- up + dt_pred d/dz visc d/dz up @@ -837,8 +845,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! diffu = horizontal viscosity terms (u_av) @@ -877,10 +887,12 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -903,7 +915,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_btstep) if (showCallTree) call callTree_leave("btstep()") - if (CS%debug) then + if (CS%debug .and. debug_redundant) then call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 15e555ee37..f454ac8d4a 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -25,6 +25,7 @@ module MOM_debugging public :: vec_chksum, vec_chksum_C, vec_chksum_B, vec_chksum_A public :: MOM_debugging_init, totalStuff, totalTandS public :: check_column_integral, check_column_integrals +public :: query_debugging_checks ! These interfaces come from MOM_checksums. public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum, hchksum_pair @@ -100,6 +101,18 @@ subroutine MOM_debugging_init(param_file) end subroutine MOM_debugging_init +!> Returns logicals indicating which debugging checks should be performed. +subroutine query_debugging_checks(do_debug, do_chksums, do_redundant) + logical, optional, intent(out) :: do_debug !< True if verbose debugging is to be output + logical, optional, intent(out) :: do_chksums !< True if checksums are to be output + logical, optional, intent(out) :: do_redundant !< True if redundant points are to be checked + + if (present(do_debug)) do_debug = debug + if (present(do_chksums)) do_chksums = debug_chksums + if (present(do_redundant)) do_redundant = debug_redundant + +end subroutine query_debugging_checks + !> Check for consistency between the duplicated points of a 3-D C-grid vector subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction, unscale) From 85c72b8c0a0cca2341c836afcd379c03cb002136 Mon Sep 17 00:00:00 2001 From: William Xu Date: Wed, 12 Jun 2024 05:27:19 -0600 Subject: [PATCH 046/128] Inline harmonic analysis The module MOM_harmonic_analysis computes the constant coefficients of sine/cosine functions for the SSH and barotropic velocity fields of each tidal constituent. --- src/core/MOM.F90 | 9 +- src/core/MOM_barotropic.F90 | 16 +- src/core/MOM_dynamics_split_RK2.F90 | 17 +- src/core/MOM_dynamics_split_RK2b.F90 | 16 +- src/diagnostics/MOM_harmonic_analysis.F90 | 430 ++++++++++++++++++ .../lateral/MOM_tidal_forcing.F90 | 19 +- 6 files changed, 496 insertions(+), 11 deletions(-) create mode 100644 src/diagnostics/MOM_harmonic_analysis.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8b34b3e6a3..9e358ab17e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -95,6 +95,7 @@ module MOM use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_grid, only : set_first_direction +use MOM_harmonic_analysis, only : HA_accum_FtF, HA_accum_FtSSH, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz @@ -389,6 +390,8 @@ module MOM !< Pointer to the control structure used for the mode-split RK2 dynamics type(MOM_dyn_split_RK2b_CS), pointer :: dyn_split_RK2b_CSp => NULL() !< Pointer to the control structure used for an alternate version of the mode-split RK2 dynamics + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() + !< Pointer to the control structure for harmonic analysis type(thickness_diffuse_CS) :: thickness_diffuse_CSp !< Pointer to the control structure used for the isopycnal height diffusive transport. !! This is also common referred to as Gent-McWilliams diffusion @@ -911,6 +914,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif + if (associated(CS%HA_CSp)) call HA_accum_FtF(Time_Local, CS%HA_CSp) call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & @@ -1020,6 +1024,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh CS%ave_ssh_ibc(i,j) = ssh(i,j) enddo ; enddo + if (associated(CS%HA_CSp)) call HA_accum_FtSSH('ssh', ssh, Time_local, G, CS%HA_CSp) if (do_dyn) then call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) @@ -3247,13 +3252,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & allocate(eta(SZI_(G),SZJ_(G)), source=0.0) if (CS%use_alt_split) then call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & - G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, restart_CSp, & + G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) else call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & - G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & + G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index a132200759..bc8fddbdde 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -16,6 +16,7 @@ module MOM_barotropic use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : HA_accum_FtSSH, harmonic_analysis_CS 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_NONE, open_boundary_query @@ -289,6 +290,7 @@ module MOM_barotropic type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -2551,6 +2553,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta enddo ; enddo + ! Accumulator is updated at the end of every baroclinic time step. + ! Harmonic analysis will not be performed of a field that is not registered. + if (associated(CS%HA_CSp) .and. find_etaav) then + call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp) + call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp) + endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) if (G%nonblocking_updates) then @@ -4402,7 +4411,7 @@ end subroutine bt_mass_source !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & - restart_CS, calc_dtbt, BT_cont, SAL_CSp) + restart_CS, calc_dtbt, BT_cont, SAL_CSp, HA_CSp) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -4428,6 +4437,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, !! barotropic flow. type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the !! SAL module. + type(harmonic_analysis_CS), target, optional :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module ! This include declares and sets the variable "version". # include "version_variable.h" @@ -4489,6 +4500,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (present(SAL_CSp)) then CS%SAL_CSp => SAL_CSp endif + if (present(HA_CSp)) then + CS%HA_CSp => HA_CSp + endif ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "SPLIT", CS%split, default=.true., do_not_log=.true.) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b545d99daa..11c3ff1873 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -47,6 +47,7 @@ module MOM_dynamics_split_RK2 use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -242,6 +243,8 @@ module MOM_dynamics_split_RK2 type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -482,7 +485,6 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass - ! PFu = d/dx M(h,T,S) ! pbce = dM/deta if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) @@ -1308,7 +1310,7 @@ end subroutine remap_dyn_split_RK2_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) @@ -1331,6 +1333,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(param_file_type), intent(in) :: param_file !< parameter file for parsing type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for @@ -1504,7 +1508,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) - if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_tides) then + call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) @@ -1538,7 +1547,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & - CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp) + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp, CS%HA_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index c6642506f9..0220db7993 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -49,6 +49,7 @@ module MOM_dynamics_split_RK2b use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -239,6 +240,8 @@ module MOM_dynamics_split_RK2b type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -1233,7 +1236,7 @@ end subroutine remap_dyn_split_RK2b_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) @@ -1256,6 +1259,8 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, type(param_file_type), intent(in) :: param_file !< parameter file for parsing type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for @@ -1415,7 +1420,12 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) - if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_tides) then + call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) @@ -1453,7 +1463,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%SAL_CSp) + CS%SAL_CSp, CS%HA_CSp) flux_units = get_flux_units(GV) thickness_units = get_thickness_units(GV) diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 new file mode 100644 index 0000000000..4a4b4ccd1f --- /dev/null +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -0,0 +1,430 @@ +!> Inline harmonic analysis (conventional) +module MOM_harmonic_analysis + +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, get_date, increment_date, & + operator(+), operator(-), operator(<), operator(>), operator(>=) +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_file_parser, only : param_file_type, get_param +use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file, & + MOM_infra_file, vardesc, MOM_field, & + var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field +use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE + +implicit none ; private + +public HA_init, HA_register, HA_accum_FtF, HA_accum_FtSSH + +#include + +integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal constituents + +!> The private control structure for storing the HA info of a particular field +type, private :: HA_type + character(len=16) :: key = "none" !< Name of the field of which harmonic analysis is to be performed + character(len=1) :: grid !< The grid on which the field is defined ('h', 'q', 'u', or 'v') + real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable :: ref(:,:) !< The initial field in arbitrary units [A] + real, allocatable :: FtSSH(:,:,:) !< Accumulator of (F' * SSH_in) in arbitrary units [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type HA_type + +!> A linked list of control structures that store the HA info of different fields +type, private :: HA_node + type(HA_type) :: this !< Control structure of the current field in the list + type(HA_node), pointer :: next !< The list of other fields +end type HA_node + +!> The public control structure of the MOM_harmonic_analysis module +type, public :: harmonic_analysis_CS ; private + logical :: HAready = .true. !< If true, perform harmonic analysis + type(time_type) :: & + time_start, & !< Start time of harmonic analysis + time_end, & !< End time of harmonic analysis + time_ref !< Reference time (t = 0) used to calculate tidal forcing + real, dimension(MAX_CONSTITUENTS) :: & + freq, & !< The frequency of a tidal constituent [T-1 ~> s-1] + phase0 !< The phase of a tidal constituent at time 0 [rad] + real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) for all fields [nondim] + integer :: nc !< The number of tidal constituents in use + integer :: length !< Number of fields of which harmonic analysis is to be performed + character(len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + character(len=255) :: path !< Path to directory where output will be written + type(unit_scale_type) :: US !< A dimensional unit scaling type + type(HA_node), pointer :: list => NULL() !< A linked list for storing the HA info of different fields +end type harmonic_analysis_CS + +contains + +!> This subroutine sets static variables used by this module and initializes CS%list. +!! THIS MUST BE CALLED AT THE END OF tidal_forcing_init. +subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, CS) + type(time_type), intent(in) :: Time !< The current model time + type(time_type), intent(in) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real, dimension(MAX_CONSTITUENTS), intent(in) :: freq !< The frequency of a tidal constituent [T-1 ~> s-1] + real, dimension(MAX_CONSTITUENTS), intent(in) :: phase0 !< The phase of a tidal constituent at time 0 [rad] + integer, intent(in) :: nc !< The number of tidal constituents in use + character(len=16), intent(in) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type) :: ha1 !< A temporary, null field used for initializing CS%list + real :: HA_start_time !< Start time of harmonic analysis [T ~> s] + real :: HA_end_time !< End time of harmonic analysis [T ~> s] + character(len=40) :: mdl="MOM_harmonic_analysis" !< This module's name + character(len=255) :: mesg + integer :: year, month, day, hour, minute, second + + ! Determine CS%time_start and CS%time_end + call get_param(param_file, mdl, "HA_START_TIME", HA_start_time, & + "Start time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be smaller than "//& + "HA_END_TIME, otherwise harmonic analysis will not be performed. "//& + "If negative, |HA_START_TIME| determines the length of harmonic analysis, "//& + "and harmonic analysis will start |HA_START_TIME| days before HA_END_TIME, "//& + "or at the beginning of the run segment, whichever occurs later.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "HA_END_TIME", HA_end_time, & + "End time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be positive "//& + "and smaller than the length of the currnet run segment, "//& + "otherwise harmonic analysis will not be performed.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + + if (HA_end_time <= 0.0) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is zero or negative. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + if (HA_end_time <= HA_start_time) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is smaller than or equal to HA_START_TIME. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + if (HA_start_time < 0.0) then + HA_start_time = HA_end_time + HA_start_time + if (HA_start_time <= 0.0) HA_start_time = 0.0 + endif + + CS%time_start = Time + real_to_time(US%T_to_s * HA_start_time) + CS%time_end = Time + real_to_time(US%T_to_s * HA_end_time) + + call get_date(Time, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: run segment starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_start, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_end, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis ends on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + + ! Set path to directory where output will be written + call get_param(param_file, mdl, "HA_PATH", CS%path, & + "Path to output files for runtime harmonic analysis.", default="./") + + ! Populate some parameters of the control structure + CS%time_ref = time_ref + CS%freq = freq + CS%phase0 = phase0 + CS%nc = nc + CS%const_name = const_name + CS%length = 0 + CS%US = US + + allocate(CS%FtF(2*nc+1,2*nc+1), source=0.0) + + ! Initialize CS%list + allocate(CS%list) + CS%list%this = ha1 + nullify(CS%list%next) + +end subroutine HA_init + +!> This subroutine registers each of the fields on which HA is to be performed. +subroutine HA_register(key, grid, CS) + character(len=*), intent(in) :: key !< Name of the current field + character(len=1), intent(in) :: grid !< The grid on which the key field is defined + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type) :: ha1 !< Control structure for the current field + type(HA_node), pointer :: tmp !< A temporary list to hold the current field + + if (.not. CS%HAready) return + + allocate(tmp) + ha1%key = trim(key) + ha1%grid = trim(grid) + tmp%this = ha1 + tmp%next => CS%list + CS%list => tmp + CS%length = CS%length + 1 + +end subroutine HA_register + +!> This subroutine accumulates the temporal basis functions in FtF. +!! The tidal constituents are those used in MOM_tidal_forcing, plus the mean (of zero frequency). +subroutine HA_accum_FtF(Time, CS) + type(time_type), intent(in) :: Time !< The current model time + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + real :: now !< The relative time compared with tidal reference [T ~> s] + real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim] + integer :: nc, c, icos, isin, cc, iccos, issin + + ! Exit the accumulator in the following cases + if (.not. CS%HAready) return + if (CS%length == 0) return + if (Time < CS%time_start) return + if (Time > CS%time_end) return + + nc = CS%nc + now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) + + ! Accumulate FtF + CS%FtF(1,1) = CS%FtF(1,1) + 1.0 !< For the zero frequency + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = cos(CS%freq(c) * now + CS%phase0(c)) + sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + CS%FtF(icos,1) = CS%FtF(icos,1) + cosomegat + CS%FtF(isin,1) = CS%FtF(isin,1) + sinomegat + CS%FtF(1,icos) = CS%FtF(icos,1) + CS%FtF(1,isin) = CS%FtF(isin,1) + do cc=c,nc + iccos = 2*cc + issin = 2*cc+1 + ccosomegat = cos(CS%freq(cc) * now + CS%phase0(cc)) + ssinomegat = sin(CS%freq(cc) * now + CS%phase0(cc)) + CS%FtF(icos,iccos) = CS%FtF(icos,iccos) + cosomegat * ccosomegat + CS%FtF(icos,issin) = CS%FtF(icos,issin) + cosomegat * ssinomegat + CS%FtF(isin,iccos) = CS%FtF(isin,iccos) + sinomegat * ccosomegat + CS%FtF(isin,issin) = CS%FtF(isin,issin) + sinomegat * ssinomegat + enddo ! cc=c,nc + enddo ! c=1,nc + +end subroutine HA_accum_FtF + +!> This subroutine accumulates the temporal basis functions in FtSSH and then calls HA_write to compute +!! harmonic constants and write results. The tidal constituents are those used in MOM_tidal_forcing, plus the +!! mean (of zero frequency). +subroutine HA_accum_FtSSH(key, data, Time, G, CS) + character(len=*), intent(in) :: key !< Name of the current field + real, dimension(:,:), intent(in) :: data !< Input data of which harmonic analysis is to be performed [A] + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type), pointer :: ha1 + type(HA_node), pointer :: tmp + real :: now !< The relative time compared with the tidal reference [T ~> s] + real :: dt !< The current time step size of the accumulator [T ~> s] + real :: cosomegat, sinomegat !< The components of the phase [nondim] + integer :: nc, i, j, k, c, icos, isin, is, ie, js, je + character(len=128) :: mesg + + ! Exit the accumulator in the following cases + if (.not. CS%HAready) return + if (CS%length == 0) return + if (Time < CS%time_start) return + if (Time > CS%time_end) return + + ! Loop through the full list to find the current field + tmp => CS%list + do k=1,CS%length + ha1 => tmp%this + if (trim(key) == trim(ha1%key)) exit + tmp => tmp%next + if (k == CS%length) return !< Do not perform harmonic analysis of a field that is not registered + enddo + + nc = CS%nc + now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) + + ! Additional processing at the initial accumulating step + if (ha1%old_time < 0.0) then + ha1%old_time = now + + write(mesg,*) "MOM_harmonic_analysis: initializing accumulator, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! Get the lower and upper bounds of input data + ha1%is = LBOUND(data,1) ; is = ha1%is + ha1%ie = UBOUND(data,1) ; ie = ha1%ie + ha1%js = LBOUND(data,2) ; js = ha1%js + ha1%je = UBOUND(data,2) ; je = ha1%je + + allocate(ha1%ref(is:ie,js:je), source=0.0) + allocate(ha1%FtSSH(is:ie,js:je,2*nc+1), source=0.0) + ha1%ref(:,:) = data(:,:) + endif + + dt = now - ha1%old_time + ha1%old_time = now !< Keep track of time so we know when Time approaches CS%time_end + + is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + ! Accumulate FtF and FtSSH + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = cos(CS%freq(c) * now + CS%phase0(c)) + sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + do j=js,je ; do i=is,ie + ha1%FtSSH(i,j,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j)) + ha1%FtSSH(i,j,icos) = ha1%FtSSH(i,j,icos) + (data(i,j) - ha1%ref(i,j)) * cosomegat + ha1%FtSSH(i,j,isin) = ha1%FtSSH(i,j,isin) + (data(i,j) - ha1%ref(i,j)) * sinomegat + enddo ; enddo + enddo ! c=1,nc + + ! Compute harmonic constants and write output as Time approaches CS%time_end + ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end + if (time_type_to_real(CS%time_end - Time) <= dt) then + call HA_write(ha1, Time, G, CS) + + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis done, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! De-register the current field and deallocate memory + ha1%key = 'none' + deallocate(ha1%ref) + deallocate(ha1%FtSSH) + endif + +end subroutine HA_accum_FtSSH + +!> This subroutine computes the harmonic constants and write output for the current field +subroutine HA_write(ha1, Time, G, CS) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(in) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + real, dimension(:,:,:), allocatable :: FtSSHw !< An array containing the harmonic constants [A] + integer :: year, month, day, hour, minute, second + integer :: nc, k, is, ie, js, je + + character(len=255) :: filename !< Output file name + type(MOM_infra_file) :: cdf !< The file handle for output harmonic constants + type(vardesc), allocatable :: cdf_vars(:) !< Output variable names + type(MOM_field), allocatable :: cdf_fields(:) !< Field type variables for the output fields + + nc = CS%nc ; is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + + ! Compute the harmonic coefficients + call HA_solver(ha1, nc, CS%FtF, FtSSHw) + + ! Output file name + call get_date(Time, year, month, day, hour, minute, second) + write(filename, '(a,"HA_",a,i0.4,i0.2,i0.2,".nc")') & + trim(CS%path), trim(ha1%key), year, month, day + + allocate(cdf_vars(2*nc+1)) + allocate(cdf_fields(2*nc+1)) + + ! Variable names + cdf_vars(1) = var_desc("z0", "m" ,"mean value", ha1%grid, '1', '1') + do k=1,nc + cdf_vars(2*k ) = var_desc(trim(CS%const_name(k))//"cos", "m", "cosine coefficient", ha1%grid, '1', '1') + cdf_vars(2*k+1) = var_desc(trim(CS%const_name(k))//"sin", "m", "sine coefficient", ha1%grid, '1', '1') + enddo + + ! Create output file + call create_MOM_file(cdf, trim(filename), cdf_vars, & + 2*nc+1, cdf_fields, SINGLE_FILE, 86400.0, G=G) + + ! Write data + call MOM_write_field(cdf, cdf_fields(1), G%domain, FtSSHw(:,:,1), 0.0) + do k=1,nc + call MOM_write_field(cdf, cdf_fields(2*k ), G%domain, FtSSHw(:,:,2*k ), 0.0) + call MOM_write_field(cdf, cdf_fields(2*k+1), G%domain, FtSSHw(:,:,2*k+1), 0.0) + enddo + + call cdf%flush() + deallocate(cdf_vars) + deallocate(cdf_fields) + deallocate(FtSSHw) + +end subroutine HA_write + +!> This subroutine computes the harmonic constants (stored in FtSSHw) using the dot products of the temporal +!! basis functions accumulated in FtF, and the dot products of the SSH (or other fields) with the temporal basis +!! functions accumulated in FtSSH. The system is solved by Cholesky decomposition. +subroutine HA_solver(ha1, nc, FtF, FtSSHw) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + integer, intent(in) :: nc !< Number of harmonic constituents + real, dimension(:,:), intent(in) :: FtF !< Accumulator of (F' * F) for all fields [nondim] + real, dimension(:,:,:), allocatable, intent(out) :: FtSSHw !< Work array for Cholesky decomposition [A] + + ! Local variables + real, dimension(:,:), allocatable :: tmp !< Work array for Cholesky decomposition [A] + real, dimension(:,:), allocatable :: FtFw !< Work array for Cholesky decomposition [nondim] + integer :: k, l, is, ie, js, je + + is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + allocate(tmp(is:ie,js:je), source=0.0) + allocate(FtFw(1:2*nc+1,1:2*nc+1), source=0.0) + allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + + FtFw(:,:) = 0.0 + do l=1,2*nc+1 + FtFw(l,l) = sqrt(FtF(l,l) - dot_product(FtFw(l,1:l-1), FtFw(l,1:l-1))) + do k=l+1,2*nc+1 + FtFw(k,l) = (FtF(k,l) - dot_product(FtFw(k,1:l-1), FtFw(l,1:l-1))) / FtFw(l,l) + enddo + enddo + + FtSSHw(:,:,:) = ha1%FtSSH(:,:,:) + do k=1,2*nc+1 + tmp(:,:) = 0.0 + do l=1,k-1 + tmp(:,:) = tmp(:,:) + FtFw(k,l) * FtSSHw(:,:,l) + enddo + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp(:,:)) / FtFw(k,k) + enddo + do k=2*nc+1,1,-1 + tmp(:,:) = 0.0 + do l=k+1,2*nc+1 + tmp(:,:) = tmp(:,:) + FtSSHw(:,:,l) * FtFw(l,k) + enddo + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp(:,:)) / FtFw(k,k) + enddo + + deallocate(tmp) + deallocate(FtFw) + +end subroutine HA_solver + +!> \namespace harmonic_analysis +!! +!! This module computes the harmonic constants which can be used to reconstruct the tidal elevation (or other +!! fields) through SSH = F * x, where F is an nt-by-2*nc matrix (nt is the number of time steps and nc is the +!! number of tidal constituents) containing the cosine/sine functions for each frequency evaluated at each time +!! step, and x is a 2*nc-by-1 vector containing the constant coefficients of the sine/cosine for each constituent +!! (i.e., the harmonic constants). At each grid point, the harmonic constants are computed using least squares, +!! +!! x = (F' * F)^{-1} * (F' * SSH_in), +!! +!! where the prime denotes matrix transpose, and SSH_in is the sea surface height (or other fields) determined by +!! the model. The dot products (F' * F) and (F' * SSH_in) are computed by accumulating the sums as the model is +!! running and stored in the arrays FtF and FtSSH, respectively. The FtF matrix is inverted as needed before +!! computing and writing out the harmonic constants. +!! +!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu), April 2024. + +end module MOM_harmonic_analysis + diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1cd8a45a78..d53c3321f9 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -9,6 +9,8 @@ module MOM_tidal_forcing use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, & + only : HA_init, HA_register, harmonic_analysis_CS use MOM_io, only : field_exists, file_exists, MOM_read_data use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -231,12 +233,13 @@ end subroutine nodal_fu !! while fields like the background viscosities are 2-D arrays. !! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with !! static memory. -subroutine tidal_forcing_init(Time, G, US, param_file, CS) +subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure + type(harmonic_analysis_CS), optional, intent(out) :: HA_CS !< Control structure for harmonic analysis ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & @@ -251,6 +254,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) 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 :: HA_ssh, HA_ubt, HA_vbt ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. @@ -523,6 +527,19 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif + if (present(HA_CS)) then + call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, HA_CS) + call get_param(param_file, mdl, "HA_SSH", HA_ssh, & + "If true, perform harmonic analysis of sea serface height.", default=.false.) + if (HA_ssh) call HA_register('ssh', 'h', HA_CS) + call get_param(param_file, mdl, "HA_UBT", HA_ubt, & + "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.) + if (HA_ubt) call HA_register('ubt', 'u', HA_CS) + call get_param(param_file, mdl, "HA_VBT", HA_vbt, & + "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.) + if (HA_vbt) call HA_register('vbt', 'v', HA_CS) + endif + id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init From caae6538680d747e924a81e78b314d4fccef6dae Mon Sep 17 00:00:00 2001 From: William Xu Date: Tue, 23 Jul 2024 16:59:52 -0500 Subject: [PATCH 047/128] Inline harmonic analysis Performance optimization for subroutine HA_solver. --- src/diagnostics/MOM_harmonic_analysis.F90 | 60 ++++++++++++++++------- 1 file changed, 41 insertions(+), 19 deletions(-) diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 index 4a4b4ccd1f..76adad5c8e 100644 --- a/src/diagnostics/MOM_harmonic_analysis.F90 +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -362,7 +362,12 @@ end subroutine HA_write !> This subroutine computes the harmonic constants (stored in FtSSHw) using the dot products of the temporal !! basis functions accumulated in FtF, and the dot products of the SSH (or other fields) with the temporal basis -!! functions accumulated in FtSSH. The system is solved by Cholesky decomposition. +!! functions accumulated in FtSSH. The system is solved by Cholesky decomposition, +!! +!! FtF * FtSSHw = FtSSH, => FtFw * (FtFw' * FtSSHw) = FtSSH, +!! +!! where FtFw is a lower triangular matrix, and the prime denotes matrix transpose. +!! subroutine HA_solver(ha1, nc, FtF, FtSSHw) type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field integer, intent(in) :: nc !< Number of harmonic constituents @@ -370,41 +375,58 @@ subroutine HA_solver(ha1, nc, FtF, FtSSHw) real, dimension(:,:,:), allocatable, intent(out) :: FtSSHw !< Work array for Cholesky decomposition [A] ! Local variables - real, dimension(:,:), allocatable :: tmp !< Work array for Cholesky decomposition [A] - real, dimension(:,:), allocatable :: FtFw !< Work array for Cholesky decomposition [nondim] - integer :: k, l, is, ie, js, je + real :: tmp0 !< Temporary variable for Cholesky decomposition [nondim] + real, dimension(:), allocatable :: tmp1 !< Temporary variable for Cholesky decomposition [nondim] + real, dimension(:,:), allocatable :: tmp2 !< Temporary variable for Cholesky decomposition [A] + real, dimension(:,:), allocatable :: FtFw !< Lower triangular matrix for Cholesky decomposition [nondim] + integer :: k, m, n, is, ie, js, je is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je - allocate(tmp(is:ie,js:je), source=0.0) + allocate(tmp1(1:2*nc+1), source=0.0) + allocate(tmp2(is:ie,js:je), source=0.0) allocate(FtFw(1:2*nc+1,1:2*nc+1), source=0.0) allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + ! Construct FtFw FtFw(:,:) = 0.0 - do l=1,2*nc+1 - FtFw(l,l) = sqrt(FtF(l,l) - dot_product(FtFw(l,1:l-1), FtFw(l,1:l-1))) - do k=l+1,2*nc+1 - FtFw(k,l) = (FtF(k,l) - dot_product(FtFw(k,1:l-1), FtFw(l,1:l-1))) / FtFw(l,l) + do m=1,2*nc+1 + tmp0 = 0.0 + do k=1,m-1 + tmp0 = tmp0 + FtFw(m,k) * FtFw(m,k) + enddo + FtFw(m,m) = sqrt(FtF(m,m) - tmp0) + tmp1(m) = 1 / FtFw(m,m) + do k=m+1,2*nc+1 + tmp0 = 0.0 + do n=1,m-1 + tmp0 = tmp0 + FtFw(k,n) * FtFw(m,n) + enddo + FtFw(k,m) = (FtF(k,m) - tmp0) * tmp1(m) enddo enddo + ! Solve for (FtFw' * FtSSHw) FtSSHw(:,:,:) = ha1%FtSSH(:,:,:) do k=1,2*nc+1 - tmp(:,:) = 0.0 - do l=1,k-1 - tmp(:,:) = tmp(:,:) + FtFw(k,l) * FtSSHw(:,:,l) + tmp2(:,:) = 0.0 + do m=1,k-1 + tmp2(:,:) = tmp2(:,:) + FtFw(k,m) * FtSSHw(:,:,m) enddo - FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp(:,:)) / FtFw(k,k) + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) enddo + + ! Solve for FtSSHw do k=2*nc+1,1,-1 - tmp(:,:) = 0.0 - do l=k+1,2*nc+1 - tmp(:,:) = tmp(:,:) + FtSSHw(:,:,l) * FtFw(l,k) + tmp2(:,:) = 0.0 + do m=k+1,2*nc+1 + tmp2(:,:) = tmp2(:,:) + FtSSHw(:,:,m) * FtFw(m,k) enddo - FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp(:,:)) / FtFw(k,k) + FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) enddo - deallocate(tmp) + deallocate(tmp1) + deallocate(tmp2) deallocate(FtFw) end subroutine HA_solver @@ -417,7 +439,7 @@ end subroutine HA_solver !! step, and x is a 2*nc-by-1 vector containing the constant coefficients of the sine/cosine for each constituent !! (i.e., the harmonic constants). At each grid point, the harmonic constants are computed using least squares, !! -!! x = (F' * F)^{-1} * (F' * SSH_in), +!! (F' * F) * x = F' * SSH_in, !! !! where the prime denotes matrix transpose, and SSH_in is the sea surface height (or other fields) determined by !! the model. The dot products (F' * F) and (F' * SSH_in) are computed by accumulating the sums as the model is From 0440ed45fd1460080910818685441b72def88a3b Mon Sep 17 00:00:00 2001 From: Yi-Cheng Teng - NOAA GFDL <143743249+yichengt900@users.noreply.github.com> Date: Fri, 19 Jul 2024 10:02:24 -0400 Subject: [PATCH 048/128] Perform unit conversion for internal heat only when it is applicable --- src/tracer/MOM_generic_tracer.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 5591e74d97..e998e3029c 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -584,13 +584,24 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) else - call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + ! tv%internal_heat is a null pointer unless DO_GEOTHERMAL = True, + ! so we have to check and only do the scaling if it is associated. + if(associated(tv%internal_heat)) then + call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, & sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & internal_heat=G%US%RZ_to_kg_m2*US%C_to_degC*tv%internal_heat(:,:), & frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) + else + call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, & + sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & + opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & + frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) + endif endif ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes From a8d43f718075bed7e082accb70d5de27042cf78f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 23 Jul 2024 11:11:05 -0800 Subject: [PATCH 049/128] Adding Bodner reference --- docs/parameterizations_lateral.rst | 3 ++- docs/zotero.bib | 14 ++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 3a3266a2bb..279a5749fe 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -32,7 +32,8 @@ Mixed layer restratification by sub-mesoscale eddies ---------------------------------------------------- Mixed layer restratification from :cite:`fox-kemper2008` and -:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat. +:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat, +which now also contains the mixed layer restratication comes from :cite: Bodner2023. Lateral diffusion ----------------- diff --git a/docs/zotero.bib b/docs/zotero.bib index c0f1ddccbb..997b1d24cb 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2760,3 +2760,17 @@ @article{Adcroft2019 journal = {J. Adv. Mod. Earth Sys.} } +@article{Bodner2023, + title={Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by Boundary Layer Turbulence}, + volume={53}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/JPO-D-21-0297.1}, + DOI={10.1175/jpo-d-21-0297.1}, + number={1}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Bodner, Abigail S. and Fox-Kemper, Baylor and Johnson, Leah and Van Roekel, Luke P. and McWilliams, James C. and Sullivan, Peter P. and Hall, Paul S. and Dong, Jihai}, + year={2023}, + month=jan, + pages={323–339} +} From d76926cbd6e654530ff7f2bcd004da926c3f4a3f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 23 Jul 2024 12:09:07 -0800 Subject: [PATCH 050/128] Failing attempt to link to mle docs. --- docs/parameterizations_lateral.rst | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 279a5749fe..2b8341b881 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -35,6 +35,8 @@ Mixed layer restratification from :cite:`fox-kemper2008` and :cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat, which now also contains the mixed layer restratication comes from :cite: Bodner2023. + :ref:`namespacemom__mixed__layer__restrat_1section_mle` + Lateral diffusion ----------------- From 780d9318577c40c6ca27b7e2d44138fe1dac6ce1 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 23 Jul 2024 13:18:59 -0800 Subject: [PATCH 051/128] Two more references --- docs/zotero.bib | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index 997b1d24cb..ff09ada402 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2772,5 +2772,32 @@ @article{Bodner2023 author={Bodner, Abigail S. and Fox-Kemper, Baylor and Johnson, Leah and Van Roekel, Luke P. and McWilliams, James C. and Sullivan, Peter P. and Hall, Paul S. and Dong, Jihai}, year={2023}, month=jan, - pages={323–339} + pages={323-–339} } + +@incollection{Niiler1977, + author={P. P. Niiler and E. B. Kraus}, + title={One-dimensional models of the upper ocean}, + booktitle={Modeling and Prediction of the Upper Layers of the Ocean}, + editor={E. B. Kraus}, + publisher={Pergamon}, + address={New York}, + pages={143-–172}, + year={1977} +} + +@article{Oberhuber1993, + title={Simulation of the Atlantic Circulation with a Coupled Sea Ice-Mixed Layer-Isopycnal General Circulation Model. Part I: Model Description}, + volume={23}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(1993)023<0808:SOTACW>2.0.CO;2}, + DOI={10.1175/1520-0485(1993)023<0808:sotacw>2.0.co;2}, + number={5}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Oberhuber, Josef M.}, + year={1993}, + month=may, + pages={808–829} +} + From ec40a7ca0b74d0e0f7c46302ce23adb7b0de8147 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 10:25:28 -0800 Subject: [PATCH 052/128] Working on documentation links --- docs/parameterizations_lateral.rst | 29 +++- docs/zotero.bib | 159 +++++++++++++++++- .../lateral/MOM_hor_visc.F90 | 14 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- .../lateral/MOM_load_love_numbers.F90 | 10 +- .../lateral/MOM_mixed_layer_restrat.F90 | 22 +-- .../lateral/MOM_self_attr_load.F90 | 8 +- .../lateral/MOM_spherical_harmonics.F90 | 6 +- .../lateral/MOM_thickness_diffuse.F90 | 4 +- .../lateral/MOM_tidal_forcing.F90 | 2 +- 10 files changed, 222 insertions(+), 34 deletions(-) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 2b8341b881..3a444098b2 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -8,6 +8,8 @@ Lateral viscosity Laplacian and bi-harmonic viscosities with linear and Smagorinsky options are implemented in MOM_hor_visc. + :ref:`namespacemom__hor__visc_1section_horizontal_viscosity` + Gent-McWilliams/TEM/isopycnal height diffusion ---------------------------------------------- @@ -20,7 +22,7 @@ scaling. A model of sub-grid scale Mesoscale Eddy Kinetic Energy (MEKE) is implement in MOM_MEKE and the associated diffusivity added in MOM_thickness_diffuse. See :cite:`jansen2015` and :cite:`marshall2010`. - :ref:`namespacemom__meke_1section_MEKE` + :ref:`namespacemom__meke_1section_MEKE` Backscatter ----------- @@ -37,15 +39,38 @@ which now also contains the mixed layer restratication comes from :cite: Bodner2 :ref:`namespacemom__mixed__layer__restrat_1section_mle` +Interface filtering +------------------- + +For layer mode, one can filter the interface thicknesses: + + :ref:`namespacemom__interface__filter_1section_interface_filter` + Lateral diffusion ----------------- See :ref:`Horizontal_Diffusion`. +See also :ref:`namespacemom__lateral__mixing__coeffs_1section_Resolution_Function` + Tidal forcing ------------- Astronomical tidal forcings and self-attraction and loading are implement in MOM_tidal_forcing. Tides can also be added via an open boundary tidal specification, -see [OBC wiki page](https://github.com/NOAA-GFDL/MOM6-examples/wiki/Open-Boundary-Conditions). +see `OBC wiki page `_. + +The Love numbers are stored internally in MOM_load_love_numbers: + + :ref:`namespacemom__load__love__numbers_1section_Love_numbers` + +While the self attraction and loading is computed in MOM_self_attr_load: + + :ref:`namespaceself__attr__load_1section_SAL` + +Spherical Harmonics +------------------- + +The model needs spherical, computed in MOM_spherical_harmonics: + :ref:`namespacemom__spherical__harmonics_1section_spherical_harmonics` diff --git a/docs/zotero.bib b/docs/zotero.bib index ff09ada402..ededf3ac55 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2524,7 +2524,7 @@ @article{visbeck1997 } @article{visbeck1996, - author = {Viscbeck, M. and J.C. Marshall and H. Jones}, + author = {Visbeck, M. and J.C. Marshall and H. Jones}, year = {1996}, title = {Dynamics of isolated convective regions in the ocean}, journal = {J. Phys. Oceanogr.}, @@ -2801,3 +2801,160 @@ @article{Oberhuber1993 pages={808–829} } +@article{Smith2003, + title={Anisotropic horizontal viscosity for ocean models}, + volume={5}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/s1463-5003(02)00016-1}, + DOI={10.1016/s1463-5003(02)00016-1}, + number={2}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Smith, Richard D. and McWilliams, James C.}, + year={2003}, + month=jan, + pages={129–156} +} + +@article{Large2001, + title={Equatorial Circulation of a Global Ocean Climate Model with Anisotropic Horizontal Viscosity}, + volume={31}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(2001)031<0518:ECOAGO>2.0.CO;2}, + DOI={10.1175/1520-0485(2001)031<0518:ecoago>2.0.co;2}, + number={2}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Large, William G. and Danabasoglu, Gokhan and McWilliams, James C. and Gent, Peter R. and Bryan, Frank O.}, + year={2001}, + month=feb, + pages={518–536} +} + +@inproceedings{Smagorinsky1993, + author={Joseph Smagorinsky}, + year={1993}, + title={Some historical remarks on the use of non-linear viscosities}, + booktitle={Large Eddy Simulation of Complex Engineering and Geophysical Flows}, + note={Proceedings of an International Workshop in Large Eddy Simulation}, + address={Cambridge, UK}, + publisher={Cambridge University Press}, + pages={1--34} +} + +@article{Barton2022, + title={Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in MPAS‐Ocean}, + volume={14}, + ISSN={1942-2466}, + url={http://dx.doi.org/10.1029/2022MS003207}, + DOI={10.1029/2022ms003207}, + number={11}, + journal={Journal of Advances in Modeling Earth Systems}, + publisher={American Geophysical Union (AGU)}, + author={Barton, Kristin N. and Pal, Nairita and Brus, Steven R. and Petersen, Mark R. and Arbic, Brian K. and Engwirda, Darren and Roberts, Andrew F. and Westerink, Joannes J. and Wirasaet, Damrongsak and Schindelegger, Michael}, + year={2022}, + month=nov +} + +@article{Brus2023, + title={Scalable self attraction and loading calculations for unstructured ocean tide models}, + volume={182}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/j.ocemod.2023.102160}, + DOI={10.1016/j.ocemod.2023.102160}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Brus, Steven R. and Barton, Kristin N. and Pal, Nairita and Roberts, Andrew F. and Engwirda, Darren and Petersen, Mark R. and Arbic, Brian K. and Wirasaet, Damrongsak and Westerink, Joannes J. and Schindelegger, Michael}, + year={2023}, + month=apr, + pages={102160} +} + +@article{Blewitt2003, + title={Self‐consistency in reference frames, geocenter definition, and surface loading of the solid Earth}, + volume={108}, + ISSN={0148-0227}, + url={http://dx.doi.org/10.1029/2002JB002082}, + DOI={10.1029/2002jb002082}, + number={B2}, + journal={Journal of Geophysical Research: Solid Earth}, + publisher={American Geophysical Union (AGU)}, + author={Blewitt, Geoffrey}, + year={2003}, + month=feb +} + +@article{Wang2012, + author={Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P.}, + year={2012}, + title={Load Love numbers and Green's functions +for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0}, + journal={Computers & Geosciences}, + volume={49}, + pages={190--199} +} + +@article{Jansen2015, + title={Parameterization of eddy fluxes based on a mesoscale energy budget}, + volume={92}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/j.ocemod.2015.05.007}, + DOI={10.1016/j.ocemod.2015.05.007}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Jansen, Malte F. and Adcroft, Alistair J. and Hallberg, Robert and Held, Isaac M.}, + year={2015}, + month=aug, + pages={28–-41} +} + +@inproceedings{Hallberg2003, + title={The ability of large-scale ocean models to accept parameterizations of boundary mixing, and a description of a refined bulk mixed-layer model}, + author={Robert Hallberg}, + year={2003}, + booktitle={Internal Gravity Waves and Small-Scale Turbulence: Proc.‘Aha Huliko ‘a Hawaiian Winter Workshop}, + pages={187--203} +} + +@article{1978, + volume={290}, + ISSN={2054-0272}, + url={http://dx.doi.org/10.1098/rsta.1978.0083}, + DOI={10.1098/rsta.1978.0083}, + number={1368}, + journal={Philosophical Transactions of the Royal Society of London. Series A, Mathematical and Physical Sciences}, + publisher={The Royal Society}, + year={1978}, + month=nov, + pages={235-–266} +} + +@article{Arbic2004, + title={The accuracy of surface elevations in forward global barotropic and baroclinic tide models}, + volume={51}, + ISSN={0967-0645}, + url={http://dx.doi.org/10.1016/j.dsr2.2004.09.014}, + DOI={10.1016/j.dsr2.2004.09.014}, + number={25–26}, + journal={Deep Sea Research Part II: Topical Studies in Oceanography}, + publisher={Elsevier BV}, + author={Arbic, Brian K. and Garner, Stephen T. and Hallberg, Robert W. and Simmons, Harper L.}, + year={2004}, + month=dec, + pages={3069-–3101} +} + +@article{Schaeffer2013, + title={Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations}, + volume={14}, + ISSN={1525-2027}, + url={http://dx.doi.org/10.1002/ggge.20071}, + DOI={10.1002/ggge.20071}, + number={3}, + journal={Geochemistry, Geophysics, Geosystems}, + publisher={American Geophysical Union (AGU)}, + author={Schaeffer, Nathanaël}, + year={2013}, + month=mar, + pages={751-–758} +} diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2a4181804b..ea06795654 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -3193,25 +3193,25 @@ subroutine hor_visc_end(CS) end subroutine hor_visc_end !> \namespace mom_hor_visc !! +!! \section section_horizontal_viscosity Horizontal viscosity in MOM +!! !! This module contains the subroutine horizontal_viscosity() that calculates the !! effects of horizontal viscosity, including parameterizations of the value of !! the viscosity itself. horizontal_viscosity() calculates the acceleration due to !! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or !! both may use a coefficient that depends on the shear and strain of the flow. !! All metric terms are retained. The Laplacian is calculated as the divergence of -!! a stress tensor, using the form suggested by Smagorinsky (1993). The biharmonic +!! a stress tensor, using the form suggested by \cite Smagorinsky1993. The biharmonic !! is calculated by twice applying the divergence of the stress tensor that is !! used to calculate the Laplacian, but without the dependence on thickness in the !! first pass. This form permits a variable viscosity, and indicates no !! acceleration for either resting fluid or solid body rotation. !! -!! The form of the viscous accelerations is discussed extensively in Griffies and -!! Hallberg (2000), and the implementation here follows that discussion closely. -!! We use the notation of Smith and McWilliams (2003) with the exception that the +!! The form of the viscous accelerations is discussed extensively in \cite griffies2000, +!! and the implementation here follows that discussion closely. +!! We use the notation of \cite Smith2003 with the exception that the !! isotropic viscosity is \f$\kappa_h\f$. !! -!! \section section_horizontal_viscosity Horizontal viscosity in MOM -!! !! In general, the horizontal stress tensor can be written as !! \f[ !! {\bf \sigma} = @@ -3357,7 +3357,7 @@ end subroutine hor_visc_end !! !! \subsection section_anisotropic_viscosity Anisotropic viscosity !! -!! Large et al., 2001, proposed enhancing viscosity in a particular direction and the +!! \cite Large2001, proposed enhancing viscosity in a particular direction and the !! approach was generalized in Smith and McWilliams, 2003. We use the second form of their !! two coefficient anisotropic viscosity (section 4.3). We also replace their !! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7315c82601..1a9afad897 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1728,7 +1728,7 @@ end subroutine VarMix_end !! \f] !! !! \todo Check this reference to Bob on/off paper. -!! The resolution function used in scaling diffusivities (Hallberg, 2010) is +!! The resolution function used in scaling diffusivities (\cite hallberg2013) is !! !! \f[ !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index 3d573d894d..94a107c4c7 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1452,15 +1452,17 @@ module MOM_load_love_numbers /), (/4, lmax+1/)) !< Load Love numbers !> \namespace mom_load_love_numbers +!! \section section_Love_numbers The Love numbers +!! !! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic !! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability !! of the SAL module. !! !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos -!! National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2022)]. The load Love numbers -!! are from Wang et al. (2012), which are in the center of mass of total Earth system reference frame (CM). When used, -!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [Blewitt (2003)], +!! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2022]. The load Love numbers +!! are from \cite Wang2012, which are in the center of mass of total Earth system reference frame (CM). When used, +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [\cite Blewitt2003], !! as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! !! References: @@ -1483,4 +1485,4 @@ module MOM_load_love_numbers !! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. !! Computers & Geosciences, 49, pp.190-199. !! https://doi.org/10.1016/j.cageo.2012.06.022 -end module MOM_load_love_numbers \ No newline at end of file +end module MOM_load_love_numbers diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index d1e0d15293..18c219bc7f 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1704,7 +1704,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "mesoscale eddy kinetic energy to the large-scale "//& "geostrophic kinetic energy or 1 plus the square of the "//& "grid spacing over the deformation radius, as detailed "//& - "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) + "by Fox-Kemper et al. (2011)", units="nondim", default=0.0) ! These parameters are only used in the OM4-era version of Fox-Kemper call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & "If true, turn on Stanley SGS T variance parameterization "// & @@ -1750,7 +1750,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & "Density difference used to detect the mixed-layer "//& "depth used for the mixed-layer eddy parameterization "//& - "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) + "by Fox-Kemper et al. (2011)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) endif call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& @@ -1965,14 +1965,14 @@ end function test_answer !! \section section_mle Mixed-layer eddy parameterization module !! !! The subroutines in this module implement a parameterization of unresolved viscous -!! mixed layer restratification of the mixed layer as described in Fox-Kemper et -!! al., 2008, and whose impacts are described in Fox-Kemper et al., 2011. +!! mixed layer restratification of the mixed layer as described in \cite fox-kemper2008, +!! and whose impacts are described in \cite fox-kemper2011. !! This is derived in part from the older parameterization that is described in -!! Hallberg (Aha Hulikoa, 2003), which this new parameterization surpasses, which -!! in turn is based on the sub-inertial mixed layer theory of Young (JPO, 1994). +!! \cite Hallberg2003, which this new parameterization surpasses, which +!! in turn is based on the sub-inertial mixed layer theory of \cite Young1994. !! There is no net horizontal volume transport due to this parameterization, and !! no direct effect below the mixed layer. A revised of the parameterization by -!! Bodner et al., 2023, is also available as an option. +!! \cite Bodner2023, is also available as an option. !! !! This parameterization sets the restratification timescale to agree with !! high-resolution studies of mixed layer restratification. @@ -1986,8 +1986,8 @@ end function test_answer !! !! The parameterization is colloquially referred to as "sub-meso". !! -!! The original Fox-Kemper et al., (2008b) paper proposed a quasi-Stokes -!! advection described by the stream function (eq. 5 of Fox-Kemper et al., 2011): +!! The original \cite fox-kemper2008-2 paper proposed a quasi-Stokes +!! advection described by the stream function (eq. 5 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi}_o = C_e \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ |f| } \mu(z) !! \f] @@ -2001,7 +2001,7 @@ end function test_answer !! \f$ \nabla \bar{b} \f$ is a depth mean buoyancy gradient averaged over the mixed layer. !! !! For use in coarse-resolution models, an upscaling of the buoyancy gradients and adaption for the equator -!! leads to the following parameterization (eq. 6 of Fox-Kemper et al., 2011): +!! leads to the following parameterization (eq. 6 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} } !! { \sqrt{ f^2 + \tau^{-2}} } \mu(z) @@ -2057,7 +2057,7 @@ end function test_answer !! available parameters. !! MLE_USE_PBL_MLD must be True to use the B23 modification. !! -!! Bodner et al., 2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ +!! \cite Bodner2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ !! to \f$ h H^2 \f$: !! \f[ !! {\bf \Psi} = C_r \frac{\Delta s |f| \bar{h} \bar{H}^2 \nabla \bar{b} \times \hat{\bf z} } diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index e7f8a73ab2..df22c9494c 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -245,19 +245,21 @@ end subroutine SAL_end !> \namespace self_attr_load !! +!! \section section_SAL Self attraction and loading +!! !! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (\cite Accad1978) and the SAL is simply !! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar !! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, -!! Arbic et al. (2004)]. +!! \cite Arbic2004]. !! !! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. !! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by !! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean -!! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. +!! developed by Los Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. !! !! References: !! diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 26258e6b8e..1782b5ae67 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -334,6 +334,8 @@ end function order2index !> \namespace mom_spherical_harmonics !! +!! \section section_spherical_harmonics Spherical harmonics +!! !! This module contains the subroutines to calculate spherical harmonic transforms (SHT), namely, forward transform !! of a two-dimensional field into a given number of spherical harmonic modes and its inverse transform. This module !! is primarily used to but not limited to calculate self-attraction and loading (SAL) term, which is mostly relevant to @@ -341,8 +343,8 @@ end function order2index !! Currently, the transforms are for t-cell fields only. !! !! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los -!! Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. The algorithm -!! for forward and inverse transforms loosely follows Schaeffer (2013). +!! Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The algorithm +!! for forward and inverse transforms loosely follows \cite Schaeffer2013. !! !! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The !! spherical harmonic coefficient of degree n and order m for a field \f$f(\theta, \phi)\f$ is calculated as follows: diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d735248417..d884a61aee 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2460,7 +2460,7 @@ end subroutine thickness_diffuse_end !! since the quantity \f$\frac{M^2}{\sqrt{N^4 + M^4}}\f$ is bounded between $-1$ and $1$ and does not change sign !! if \f$N^2<0\f$. !! -!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! Optionally, the method of \cite ferrari2010, can be used to obtain the streamfunction which solves the !! vertically elliptic equation: !! \f[ !! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = -( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} @@ -2478,7 +2478,7 @@ end subroutine thickness_diffuse_end !! \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 buoyancy frequency prescribed by Visbeck et al., 1996. +!! times the buoyancy frequency prescribed by \cite visbeck1996. !! !! 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). diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index d53c3321f9..740977c7b9 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -765,7 +765,7 @@ end subroutine tidal_forcing_end !! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and !! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in !! combination with the scalar approximation to iterate the SAL to -!! convergence (for details, see Arbic et al., 2004, DSR II). With +!! convergence (for details, see \cite Arbic2004). With !! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files !! must be provided to describe each constituent's properties from !! a previous solution. The online SAL calculations that are functions From 0e17b7389fb3073487bd0317c7fa1b3b28fb0447 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 11:03:53 -0800 Subject: [PATCH 053/128] Added Young reference --- docs/zotero.bib | 9 +++++++++ src/parameterizations/lateral/MOM_load_love_numbers.F90 | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index ededf3ac55..8ea5c05c38 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2958,3 +2958,12 @@ @article{Schaeffer2013 month=mar, pages={751-–758} } + +@article{Young1994, + author={Young, W.}, + title={The subinertial mixed layer approximation}, + journal={J. Phys. Oceanogr.}, + volume={24}, + pages={1812--1826}, + year={1994} +} diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index 94a107c4c7..b0251f5fb0 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1460,7 +1460,7 @@ module MOM_load_love_numbers !! !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos -!! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2022]. The load Love numbers +!! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The load Love numbers !! are from \cite Wang2012, which are in the center of mass of total Earth system reference frame (CM). When used, !! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [\cite Blewitt2003], !! as in subroutine calc_love_scaling in MOM_tidal_forcing module. From 369d716ba8da35ef66282cdf4133624271c82355 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 11:20:11 -0800 Subject: [PATCH 054/128] Fix line length in comment --- src/parameterizations/lateral/MOM_load_love_numbers.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index b0251f5fb0..c8bd8bbc3c 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1462,8 +1462,8 @@ module MOM_load_love_numbers !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos !! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The load Love numbers !! are from \cite Wang2012, which are in the center of mass of total Earth system reference frame (CM). When used, -!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [\cite Blewitt2003], -!! as in subroutine calc_love_scaling in MOM_tidal_forcing module. +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) +!! [\cite Blewitt2003], as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! !! References: !! From 86b4c85e5ecd02cc2ec5361f84a65bbed6bda3cc Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 11:40:05 -0800 Subject: [PATCH 055/128] Delete duplicate entry --- docs/forcing.rst | 12 ++++++------ docs/zotero.bib | 11 ----------- .../vertical/MOM_bulk_mixed_layer.F90 | 2 +- 3 files changed, 7 insertions(+), 18 deletions(-) diff --git a/docs/forcing.rst b/docs/forcing.rst index 8496317608..21539d46d0 100644 --- a/docs/forcing.rst +++ b/docs/forcing.rst @@ -1,23 +1,23 @@ Forcing ======= Data Override -------- +------------- When running MOM6 with the Flexible Modelling System (FMS) coupler, forcing can be specified by a `data_table` file. This is particularly useful when running MOM6 with a data atmosphere, as paths to the relevent atmospheric forcing products (eg. JRA55-do or ERA5) can be provided here. Each item in the data table must be separated by a new line, and contains the following information: | ``gridname``: The component of the model this data applies to. eg. `atm` `ocn` `lnd` `ice`. | ``fieldname_code``: The field name according to the model component. eg. `salt` -| ``fieldname_file``: The name of the field within the source file. +| ``fieldname_file``: The name of the field within the source file. | ``file_name``: Path to the source file. | ``interpol_method``: Interpolation method eg. `bilinear` -| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. +| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. +| -| The data table is commonly formatted by specifying each of the fields in the order listed above, with a new line for each entry. Example Format: "ATM", "t_bot", "t2m", "./INPUT/2t_ERA5.nc", "bilinear", 1.0 -A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. +A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. Speficying a constant value: Rather than overriding with data from a file, one can also set a field to constant. To do this, pass empty strings to `fieldname_file` and `file_name`. The `factor` now corresponds to the override value. For example, the following sets the temperature at the bottom of the atmosphere to 290 Kelvin. @@ -26,7 +26,7 @@ Speficying a constant value: "ATM", "t_bot", "", "", "bilinear", 290.0 Which units do I need? - For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. + For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. .. toctree:: diff --git a/docs/zotero.bib b/docs/zotero.bib index 8ea5c05c38..c58089236b 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2775,17 +2775,6 @@ @article{Bodner2023 pages={323-–339} } -@incollection{Niiler1977, - author={P. P. Niiler and E. B. Kraus}, - title={One-dimensional models of the upper ocean}, - booktitle={Modeling and Prediction of the Upper Layers of the Ocean}, - editor={E. B. Kraus}, - publisher={Pergamon}, - address={New York}, - pages={143-–172}, - year={1977} -} - @article{Oberhuber1993, title={Simulation of the Atlantic Circulation with a Coupled Sea Ice-Mixed Layer-Isopycnal General Circulation Model. Part I: Model Description}, volume={23}, diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 561ace60a7..4c39d9c11e 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -4256,7 +4256,7 @@ end function EF4 !! !! This file contains the subroutine (bulkmixedlayer) that !! implements a Kraus-Turner-like bulk mixed layer, based on the work -!! of various people, as described in the review paper by \cite Niiler1977, +!! of various people, as described in the review paper by \cite niiler1977, !! with particular attention to the form proposed by \cite Oberhuber1993, !! with an extension to a refined bulk mixed layer as described in !! Hallberg (\cite muller2003). The physical processes portrayed in From fb40a4ace2b8ecf5c72f3b994e43290b1b6042d2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 12:01:46 -0800 Subject: [PATCH 056/128] Another duplicate bib entry --- docs/zotero.bib | 2 +- src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index c58089236b..fe5dd37909 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2775,7 +2775,7 @@ @article{Bodner2023 pages={323-–339} } -@article{Oberhuber1993, +@article{Oberhuber1993a, title={Simulation of the Atlantic Circulation with a Coupled Sea Ice-Mixed Layer-Isopycnal General Circulation Model. Part I: Model Description}, volume={23}, ISSN={1520-0485}, diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 4c39d9c11e..792dae1411 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -4257,7 +4257,7 @@ end function EF4 !! This file contains the subroutine (bulkmixedlayer) that !! implements a Kraus-Turner-like bulk mixed layer, based on the work !! of various people, as described in the review paper by \cite niiler1977, -!! with particular attention to the form proposed by \cite Oberhuber1993, +!! with particular attention to the form proposed by \cite Oberhuber1993a, !! with an extension to a refined bulk mixed layer as described in !! Hallberg (\cite muller2003). The physical processes portrayed in !! this subroutine include convective adjustment and mixed layer entrainment From 4fa86fdbcc042e2ca34076df276cd745c20a4773 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Jul 2024 21:32:44 -0800 Subject: [PATCH 057/128] Another duplicate ref --- docs/zotero.bib | 19 +++---------------- src/parameterizations/lateral/MOM_MEKE.F90 | 6 +++--- .../lateral/MOM_hor_visc.F90 | 4 ++-- .../lateral/MOM_load_love_numbers.F90 | 2 +- 4 files changed, 9 insertions(+), 22 deletions(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index fe5dd37909..abaeea4c72 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2873,8 +2873,9 @@ @article{Blewitt2003 month=feb } -@article{Wang2012, - author={Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P.}, +@article{Wang2012-2, + author={Wang, H. and Xiang, L. and Jia, L. and Jiang, L. and Wang, Z. and Hu, B. + and Gao, P.}, year={2012}, title={Load Love numbers and Green's functions for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0}, @@ -2883,20 +2884,6 @@ @article{Wang2012 pages={190--199} } -@article{Jansen2015, - title={Parameterization of eddy fluxes based on a mesoscale energy budget}, - volume={92}, - ISSN={1463-5003}, - url={http://dx.doi.org/10.1016/j.ocemod.2015.05.007}, - DOI={10.1016/j.ocemod.2015.05.007}, - journal={Ocean Modelling}, - publisher={Elsevier BV}, - author={Jansen, Malte F. and Adcroft, Alistair J. and Hallberg, Robert and Held, Isaac M.}, - year={2015}, - month=aug, - pages={28–-41} -} - @inproceedings{Hallberg2003, title={The ability of large-scale ocean models to accept parameterizations of boundary mixing, and a description of a refined bulk mixed-layer model}, author={Robert Hallberg}, diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index f3bd9e8934..c3859c3bd1 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1892,7 +1892,7 @@ end subroutine MEKE_end !! \f$ U_b \f$ is a constant background bottom velocity scale and is !! typically not used (i.e. set to zero). !! -!! Following Jansen et al., 2015, the projection of eddy energy on to the bottom +!! Following \cite jansen2015, the projection of eddy energy on to the bottom !! is given by the ratio of bottom energy to column mean energy: !! \f[ !! \gamma_b^2 = \frac{E_b}{E} = \gamma_{d0} @@ -1924,12 +1924,12 @@ end subroutine MEKE_end !! \f[ \kappa_M = \gamma_\kappa \sqrt{ \gamma_t^2 U_e^2 A_\Delta } \f] !! !! where \f$ A_\Delta \f$ is the area of the grid cell. -!! Following Jansen et al., 2015, we now use +!! Following \cite jansen2015, we now use !! !! \f[ \kappa_M = \gamma_\kappa l_M \sqrt{ \gamma_t^2 U_e^2 } \f] !! !! where \f$ \gamma_\kappa \in [0,1] \f$ is a non-dimensional factor and, -!! following Jansen et al., 2015, \f$\gamma_t^2\f$ is the ratio of barotropic +!! following \cite jansen2015, \f$\gamma_t^2\f$ is the ratio of barotropic !! eddy energy to column mean eddy energy given by !! \f[ !! \gamma_t^2 = \frac{E_t}{E} = \left( 1 + c_{t} \frac{L_d}{L_f} \right)^{-\frac{1}{4}} diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index ea06795654..4a901beab0 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -3195,9 +3195,9 @@ end subroutine hor_visc_end !! !! \section section_horizontal_viscosity Horizontal viscosity in MOM !! -!! This module contains the subroutine horizontal_viscosity() that calculates the +!! This module contains the subroutine horizontal_viscosity that calculates the !! effects of horizontal viscosity, including parameterizations of the value of -!! the viscosity itself. horizontal_viscosity() calculates the acceleration due to +!! the viscosity itself. Subroutine horizontal_viscosity calculates the acceleration due to !! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or !! both may use a coefficient that depends on the shear and strain of the flow. !! All metric terms are retained. The Laplacian is calculated as the divergence of diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index c8bd8bbc3c..8faf3aafab 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1461,7 +1461,7 @@ module MOM_load_love_numbers !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos !! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The load Love numbers -!! are from \cite Wang2012, which are in the center of mass of total Earth system reference frame (CM). When used, +!! are from \cite Wang2012-2, which are in the center of mass of total Earth system reference frame (CM). When used, !! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) !! [\cite Blewitt2003], as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! From d93f8bf6b2b8bdb5d661553fbb82dca2eca21c33 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Jul 2024 14:13:27 -0800 Subject: [PATCH 058/128] Clean out another duplicate ref. --- docs/ocean.bib | 12 ------------ docs/zotero.bib | 10 +++++----- src/parameterizations/lateral/MOM_hor_visc.F90 | 10 +++++----- .../lateral/MOM_interface_filter.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 6 +++--- .../lateral/MOM_mixed_layer_restrat.F90 | 15 ++++++++------- .../lateral/MOM_self_attr_load.F90 | 4 ++-- 7 files changed, 24 insertions(+), 35 deletions(-) diff --git a/docs/ocean.bib b/docs/ocean.bib index ec35116efc..33107fbae1 100644 --- a/docs/ocean.bib +++ b/docs/ocean.bib @@ -10,18 +10,6 @@ @article{Adcroft2004 journal = {Ocean Modelling} } -@article{Adcroft2019, - doi = {10.1029/2019ms001726}, - year = 2019, - publisher = {American Geophysical Union ({AGU})}, - volume = {11}, - number = {10}, - pages = {3167--3211}, - author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, - title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, - journal = {J. Adv. Mod. Earth Sys.} -} - @article{Campin2004, doi = {10.1016/s1463-5003(03)00009-x}, year = 2004, diff --git a/docs/zotero.bib b/docs/zotero.bib index abaeea4c72..1120771b8a 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -967,7 +967,7 @@ @article{bitz1999 pages = {15669--15677} } -@inproceedings{briegleb2007, +@incollection{briegleb2007, series = {Technical {Note}}, title = {A {Delta}-{Eddington} {Mutiple} {Scattering} {Parameterization} for {Solar} {Radiation} in the {Sea} {Ice} {Component} of the {Community} {Climate} {System} {Model} {\textbar} {OpenSky} {Repository}}, url = {http://opensky.ucar.edu/islandora/object/technotes:484}, @@ -2447,7 +2447,7 @@ @article{russell1981 doi = {10.1175/1520-0450(1981)020<1483:ANFDSF>2.0.CO;2} } -@inproceedings{huynh1997, +@incollection{huynh1997, title = {Schemes and constraints for advection}, booktitle = {Fifteenth International Conference on Numerical Methods in Fluid Dynamics}, @@ -2564,7 +2564,7 @@ @article{marshall2010 doi = {10.1016/j.ocemod.2010.02.001} } -@inproceedings{millero1978, +@incollection{millero1978, author = {Millero, F.J.}, title = {Freezing point of seawater}, note = {Annex 6}, @@ -2820,7 +2820,7 @@ @article{Large2001 pages={518–536} } -@inproceedings{Smagorinsky1993, +@incollection{Smagorinsky1993, author={Joseph Smagorinsky}, year={1993}, title={Some historical remarks on the use of non-linear viscosities}, @@ -2884,7 +2884,7 @@ @article{Wang2012-2 pages={190--199} } -@inproceedings{Hallberg2003, +@incollection{Hallberg2003, title={The ability of large-scale ocean models to accept parameterizations of boundary mixing, and a description of a refined bulk mixed-layer model}, author={Robert Hallberg}, year={2003}, diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 4a901beab0..94afd0c858 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2044,9 +2044,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, end subroutine horizontal_viscosity -!> Allocates space for and calculates static variables used by horizontal_viscosity(). +!> Allocates space for and calculates static variables used by horizontal_viscosity. !! hor_visc_init calculates and stores the values of a number of metric functions that -!! are used in horizontal_viscosity(). +!! are used in horizontal_viscosity. subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -3259,7 +3259,7 @@ end subroutine hor_visc_end !! \f} !! !! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example, -!! \f$\kappa_h\f$ may vary with the shear, as proposed by Smagorinsky (1993). +!! \f$\kappa_h\f$ may vary with the shear, as proposed by \cite Smagorinsky1993. !! !! The accelerations resulting form the divergence of the stress tensor are !! \f{eqnarray*}{ @@ -3357,8 +3357,8 @@ end subroutine hor_visc_end !! !! \subsection section_anisotropic_viscosity Anisotropic viscosity !! -!! \cite Large2001, proposed enhancing viscosity in a particular direction and the -!! approach was generalized in Smith and McWilliams, 2003. We use the second form of their +!! \cite Large2001 proposed enhancing viscosity in a particular direction and the +!! approach was generalized in \cite Smith2003. We use the second form of their !! two coefficient anisotropic viscosity (section 4.3). We also replace their !! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and !! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index ea86b80594..a63a2fc141 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -480,7 +480,7 @@ end subroutine interface_filter_end !! filter, depending on the order of the filter, or to the slope for a Laplacian !! filter !! \f[ -!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_smooth} +!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_{smooth}} !! \f] !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including a diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1a9afad897..eb1cf7b1cf 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1734,8 +1734,8 @@ end subroutine VarMix_end !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} !! \f] !! -!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), -!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). +!! The resolution function can be applied independently to thickness diffusion \(module mom_thickness_diffuse\), +!! tracer diffusion \(mom_tracer_hordiff\) lateral viscosity \(mom_hor_visc\). !! !! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. !! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 @@ -1757,7 +1757,7 @@ end subroutine VarMix_end !! \section section_Vicbeck Visbeck diffusivity !! !! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, -!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse but calculated in this module. !! !! \f[ !! \kappa_h = \alpha_s L_s^2 S N diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 18c219bc7f..f5deea1f66 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1971,15 +1971,15 @@ end function test_answer !! \cite Hallberg2003, which this new parameterization surpasses, which !! in turn is based on the sub-inertial mixed layer theory of \cite Young1994. !! There is no net horizontal volume transport due to this parameterization, and -!! no direct effect below the mixed layer. A revised of the parameterization by -!! \cite Bodner2023, is also available as an option. +!! no direct effect below the mixed layer. A revised version of the parameterization by +!! \cite Bodner2023 is also available as an option. !! !! This parameterization sets the restratification timescale to agree with !! high-resolution studies of mixed layer restratification. !! -!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of +!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of !! order a few tens, proportional to the ratio of the deformation radius or the -!! grid scale (whichever is smaller to the dominant horizontal length-scale of the +!! grid scale (whichever is smaller) to the dominant horizontal length-scale of the !! sub-meso-scale mixed layer instabilities. !! !! \subsection section_mle_nutshell "Sub-meso" in a nutshell @@ -2011,14 +2011,15 @@ end function test_answer !! \f$ \tau \f$ is a time-scale for mixing momentum across the mixed layer. !! \f$ l_f \f$ is thought to be of order hundreds of meters. !! -!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter FOX_KEMPER_ML_RESTRAT, -!! so that in practice the parameterization is: +!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter +!! FOX_KEMPER_ML_RESTRAT, so that in practice the parameterization is: !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ \sqrt{ f^2 + \tau^{-2}} } \mu(z) !! \f] !! with non-unity \f$ \Gamma_\Delta \f$. !! !! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. +!! !! \todo Explain expression for momentum mixing time-scale. !! !! | Symbol | Module parameter | @@ -2102,7 +2103,7 @@ end function test_answer !! | \f$ \tau_{h+} \f$ | MLE\%BLD_GROWING_TFILTER | !! | \f$ \tau_{h-} \f$ | MLE\%BLD_DECAYING_TFILTER | !! | \f$ \tau_{H+} \f$ | MLE\%MLD_GROWING_TFILTER | -!! | \f$ \tau_{H-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! | \f$ \tau_{H-} \f$ | MLE\%MLD_DECAYING_TFILTER | !! !! \subsection section_mle_ref References !! diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index df22c9494c..fd6c0c1e5f 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -251,12 +251,12 @@ end subroutine SAL_end !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (\cite Accad1978) and the SAL is simply +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied [\cite Accad1978] and the SAL is simply !! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar !! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, !! \cite Arbic2004]. !! -!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. !! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by !! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean !! developed by Los Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. From 078ec30d80254f86423d893b530b50cc71ab7cc0 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Jul 2024 14:25:43 -0800 Subject: [PATCH 059/128] Fix the Accad ref. --- docs/zotero.bib | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index 1120771b8a..bbd2e30478 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2892,7 +2892,7 @@ @incollection{Hallberg2003 pages={187--203} } -@article{1978, +@article{Accad1978, volume={290}, ISSN={2054-0272}, url={http://dx.doi.org/10.1098/rsta.1978.0083}, @@ -2902,7 +2902,10 @@ @article{1978 publisher={The Royal Society}, year={1978}, month=nov, - pages={235-–266} + pages={235-–266}, + author={Accad, Y. and Pekeris, C.L.}, + title={Solution of the tidal equations for the M2 and S2 tides in the world oceans from a + knowledge of the tidal potential alone} } @article{Arbic2004, From da3ec99d2d99158e1695525f4e13b24514fd5a88 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Jul 2024 15:21:45 -0800 Subject: [PATCH 060/128] still cleaning the docs --- docs/parameterizations_lateral.rst | 5 +---- .../lateral/MOM_self_attr_load.F90 | 15 ++++++++------- .../lateral/MOM_spherical_harmonics.F90 | 8 ++++---- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 3a444098b2..ce223e5155 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -68,9 +68,6 @@ While the self attraction and loading is computed in MOM_self_attr_load: :ref:`namespaceself__attr__load_1section_SAL` -Spherical Harmonics -------------------- - -The model needs spherical, computed in MOM_spherical_harmonics: +The self attraction and loading needs spherical harmonics, computed in MOM_spherical_harmonics: :ref:`namespacemom__spherical__harmonics_1section_spherical_harmonics` diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index fd6c0c1e5f..f72b6f513e 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -251,14 +251,15 @@ end subroutine SAL_end !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied [\cite Accad1978] and the SAL is simply -!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar -!! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, -!! \cite Arbic2004]. +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (\cite Accad1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH. +!! For tides, the scalar approximation can also be used to iterate the SAL to convergence [see +!! USE_PREVIOUS_TIDES in MOM_tidal_forcing, \cite Arbic2004]. !! -!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. -!! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by -!! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate +!! SAL. Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is +!! set by SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across +!! Scales (MPAS)-Ocean !! developed by Los Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. !! !! References: diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 1782b5ae67..4f9cee03aa 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -361,7 +361,7 @@ end function order2index !! \f[ !! f^m_n = \sum^{Nj}_{0}\sum^{Ni}_{0}f(i,j)Y^m_n(i,j)A(i,j)/r_e^2 !! \f] -!! where $A$ is the area of the cell and $r_e$ is the radius of the Earth. +!! where \f$A\f$ is the area of the cell and \f$r_e\f$ is the radius of the Earth. !! !! In inverse transform, the first N degree spherical harmonic coefficients are used to reconstruct a two-dimensional !! physical field: @@ -374,10 +374,10 @@ end function order2index !! array vectorization. !! !! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. -!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. !! -!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls whether this is done -!! in a bit-wise reproducing way or not. +!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls +!! whether this is done in a bit-wise reproducing way or not. !! !! References: !! From b7fee4d14a1e042885ad5c308aa509e65d5ede52 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Jul 2024 16:28:27 -0800 Subject: [PATCH 061/128] Fix case --- docs/parameterizations_lateral.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index ce223e5155..9f161d5a04 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -64,7 +64,7 @@ The Love numbers are stored internally in MOM_load_love_numbers: :ref:`namespacemom__load__love__numbers_1section_Love_numbers` -While the self attraction and loading is computed in MOM_self_attr_load: +while the self attraction and loading is computed in MOM_self_attr_load: :ref:`namespaceself__attr__load_1section_SAL` From 4f1ecf4dd6b6f895ac81d8da55b2dde651161663 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Jul 2024 22:02:09 -0800 Subject: [PATCH 062/128] Cleaning up tides section --- docs/parameterizations_lateral.rst | 9 ++++++--- src/parameterizations/lateral/MOM_tidal_forcing.F90 | 12 +++++++----- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 9f161d5a04..d175c7e8bb 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -56,9 +56,9 @@ See also :ref:`namespacemom__lateral__mixing__coeffs_1section_Resolution_Functio Tidal forcing ------------- -Astronomical tidal forcings and self-attraction and loading are implement in MOM_tidal_forcing. -Tides can also be added via an open boundary tidal specification, -see `OBC wiki page `_. +Astronomical tidal forcings and self-attraction and loading are implement in + + :ref:`namespacetidal__forcing_1section_tides` The Love numbers are stored internally in MOM_load_love_numbers: @@ -71,3 +71,6 @@ while the self attraction and loading is computed in MOM_self_attr_load: The self attraction and loading needs spherical harmonics, computed in MOM_spherical_harmonics: :ref:`namespacemom__spherical__harmonics_1section_spherical_harmonics` + +Tides can also be added via an open boundary tidal specification, +see `OBC wiki page `_. diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 740977c7b9..177becf84f 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -744,6 +744,8 @@ end subroutine tidal_forcing_end !> \namespace tidal_forcing !! +!! \section section_tides Tidal forcing +!! !! Code by Robert Hallberg, August 2005, based on C-code by Harper !! Simmons, February, 2003, in turn based on code by Brian Arbic. !! @@ -762,14 +764,14 @@ end subroutine tidal_forcing_end !! !! In addition, approaches to calculate self-attraction and loading !! due to tides (harmonics of astronomical forcing frequencies) -!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and -!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in !! combination with the scalar approximation to iterate the SAL to !! convergence (for details, see \cite Arbic2004). With -!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files -!! must be provided to describe each constituent's properties from +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input +!! files must be provided to describe each constituent's properties from !! a previous solution. The online SAL calculations that are functions !! of SSH (rather should be bottom pressure anmoaly), either a scalar !! approximation or with spherical harmonic transforms, are located in -!! MOM_self_attr_load. +!! MOM_self_attr_load. end module MOM_tidal_forcing From 1b39d07be2787787907db6aa382dc61e3484709d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jul 2024 14:38:26 -0400 Subject: [PATCH 063/128] *+Fix non-Boussinesq MASS_WEIGHT_IN_PGF bug Optionally corrected a bug (essentially a sign error) in the selection of where MASS_WEIGHT_IN_PRESSURE_GRADIENT is applied in non-Boussinesq test cases. The (incorrect) non-Boussinesq version of the test for where interfaces are outside of the range of hydrostatic consistency due to interactions with bathymetry was converted from the (correct) Boussinesq version without properly taking into account that pressure increases downward while height increases upward. This bug is repeated 12 times in 6 different specific volume integral routines, including in the analytical specific volume integrals with 4 equations of state. To accommodate these corrections as well as a future expansion of the mass weighting to apply near the surface under ice-shelves or icebergs, the previous optional logical argument (useMassWghtInterp) was replaced with a new optional integer argument (MassWghtInterp) that can be used to encode information about where this weighting is applied as well as whether to fix this bug. This combination of settings (MASS_WEIGHT_IN_PRESSURE_GRADIENT = True and non-Boussinesq) does not seem to be widely used yet (it is not used in the GFDL regression suite), so rather than preserving the old (incorrect) solutions by default, this bug is corrected by default. However, the previous answers can be recovered by setting the new runtime parameter MASS_WEIGHT_IN_PGF_NONBOUS_BUG to true. This parameter that is only used (and logged) for non-Boussinesq cases with MASS_WEIGHT_IN_PRESSURE_GRADIENT set to true. It is intended that this new runtime bug-fix parameter will be obsoleted with an aggressive schedule if it is not needed to recreate any production runs. In addition, there are two new diagnostics, MassWt_u and MassWt_v, that show the fractional (0 to 1) effects of the mass weighting in the pressure gradient forces at the velocity points, along with the new diagnostic subroutines diagnose_mass_weight_Z and diagnose_mass_weight_p that calculate these diagnostics by layer in code that replicates the 13 copies for various equations of state and vertical structures within layers. By default, this commit does change answers in non-Boussinesq cases that use MASS_WEIGHT_IN_PRESSURE_GRADIENT = True, and there is a new runtime parameter in such cases. There are also two new diagnostics. Answers are bitwise identical in all Boussinesq cases. --- src/core/MOM_PressureForce_FV.F90 | 60 ++++- src/core/MOM_density_integrals.F90 | 244 ++++++++++++++---- src/equation_of_state/MOM_EOS.F90 | 36 +-- src/equation_of_state/MOM_EOS_Wright.F90 | 50 ++-- src/equation_of_state/MOM_EOS_Wright_full.F90 | 50 ++-- src/equation_of_state/MOM_EOS_Wright_red.F90 | 50 ++-- src/equation_of_state/MOM_EOS_linear.F90 | 50 ++-- 7 files changed, 378 insertions(+), 162 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 5d0f4ff167..9c4f355692 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -20,6 +20,7 @@ module MOM_PressureForce_FV use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_density_integrals, only : int_spec_vol_dp_generic_plm use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm +use MOM_density_integrals, only : diagnose_mass_weight_Z, diagnose_mass_weight_p use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private @@ -46,7 +47,7 @@ module MOM_PressureForce_FV type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -71,6 +72,8 @@ module MOM_PressureForce_FV integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier integer :: id_p_stanley = -1 !< Diagnostic identifier + integer :: id_MassWt_u = -1 !< Diagnostic identifier + integer :: id_MassWt_v = -1 !< Diagnostic identifier type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -146,6 +149,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). @@ -194,6 +201,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ alpha_ref = 1.0 / CS%Rho0 I_gEarth = 1.0 / GV%g_Earth + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif + if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -263,7 +274,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & - useMassWghtInterp=CS%useMassWghtInterp) + MassWghtInterp=CS%MassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") @@ -277,8 +288,11 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp=CS%useMassWghtInterp) + MassWghtInterp=CS%MassWghtInterp) endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_p(p(:,:,K), p(:,:,K+1), dp_neglect, p(:,:,nz+1), G%HI, & + MassWt_u(:,:,k), MassWt_v(:,:,k)) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -468,6 +482,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -543,6 +559,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! of salinity within each layer [S ~> ppt]. T_t, T_b ! Top and bottom edge values for linear reconstructions ! of temperature within each layer [C ~> degC]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance ! in Stanley parameterization. @@ -591,6 +611,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif + if (CS%tides_answer_date>20230630) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = -G%bathyT(i,j) @@ -744,20 +768,20 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & - useMassWghtInterp=CS%useMassWghtInterp, & + MassWghtInterp=CS%MassWghtInterp, & use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & - useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) + MassWghtInterp=CS%MassWghtInterp, Z_0p=G%Z_ref) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & - CS%useMassWghtInterp, Z_0p=G%Z_ref) + CS%MassWghtInterp, Z_0p=G%Z_ref) endif if (GV%Z_to_H /= 1.0) then !$OMP parallel do default(shared) @@ -765,6 +789,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H enddo ; enddo endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), dz_neglect, G%bathyT, G%HI, & + MassWt_u(:,:,k), MassWt_v(:,:,k)) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -955,6 +982,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) @@ -978,6 +1007,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] integer :: default_answer_date ! Global answer date + logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S + logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -1014,10 +1045,20 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", useMassWghtInterp, & "If true, use mass weighting when interpolating T/S for "//& "integrals near the bathymetry in FV pressure gradient "//& "calculations.", default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_NONBOUS_BUG", MassWghtInterp_NonBous_bug, & + "If true, use a masking bug in non-Boussinesq calculations with mass weighting "//& + "when interpolating T/S for integrals near the bathymetry in FV pressure "//& + "gradient calculations.", & + default=.false., do_not_log=(GV%Boussinesq .or. (.not.useMassWghtInterp))) + CS%MassWghtInterp = 0 + if (useMassWghtInterp) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 0) ! Same as CS%MassWghtInterp + 1 + if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) @@ -1068,6 +1109,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif + CS%id_MassWt_u = register_diag_field('ocean_model', 'MassWt_u', diag%axesCuL, Time, & + 'The fractional mass weighting at u-point PGF calculations', 'nondim') + CS%id_MassWt_v = register_diag_field('ocean_model', 'MassWt_v', diag%axesCvL, Time, & + 'The fractional mass weighting at v-point PGF calculations', 'nondim') + CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 6d80d4dd55..d96116ba0c 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -31,6 +31,7 @@ module MOM_density_integrals public int_spec_vol_dp_generic_plm public avg_specific_vol public find_depth_of_pressure_in_cell +public diagnose_mass_weight_Z, diagnose_mass_weight_p contains @@ -39,7 +40,7 @@ module MOM_density_integrals !! required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -77,16 +78,16 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p=Z_0p) else call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif end subroutine int_density_dz @@ -96,7 +97,7 @@ end subroutine int_density_dz !! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, use_inaccurate_form, Z_0p) + dz_neglect, MassWghtInterp, use_inaccurate_form, Z_0p) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [C ~> degC] @@ -134,8 +135,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] @@ -190,13 +191,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & endif do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (do_massWeight) then if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") + "bathyT must be present if MassWghtInterp is present and true.") if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + "dz_neglect must be present if MassWghtInterp is present and true.") + endif ! Set the loop ranges for equation of state calculations at various points. EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) @@ -368,7 +369,7 @@ end subroutine int_density_dz_generic_pcm !! T and S are linear profiles. subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, & + intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, & use_inaccurate_form, Z_0p) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays @@ -409,8 +410,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] @@ -481,13 +482,9 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & I_Rho = 1.0 / rho_0 z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif + if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif use_rho_ref = .true. - if (present(use_inaccurate_form)) then - if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form - endif + if (present(use_inaccurate_form)) use_rho_ref = .not. use_inaccurate_form use_varT = .false. !ensure initialized use_covarTS = .false. @@ -773,7 +770,7 @@ end subroutine int_density_dz_generic_plm !! are parabolic profiles subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, & - dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, Z_0p) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -813,8 +810,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of @@ -884,9 +881,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & I_Rho = 1.0 / rho_0 z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif + if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif ! In event PPM calculation is bypassed with use_PPM=False s6 = 0. @@ -1179,7 +1174,7 @@ end subroutine int_density_dz_generic_ppm !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1215,17 +1210,17 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals if (EOS_quadrature(EOS)) then call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, MassWghtInterp) else call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, MassWghtInterp) endif end subroutine int_specific_vol_dp @@ -1237,7 +1232,7 @@ end subroutine int_specific_vol_dp !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [C ~> degC] @@ -1273,9 +1268,9 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1308,6 +1303,7 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state @@ -1320,14 +1316,15 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (do_massWeight) then if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") + "bathyP must be present if MassWghtInterp is present and true.") if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + "dP_neglect must be present if MassWghtInterp is present and true.") + endif ! Set the loop ranges for equation of state calculations at various points. EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(ieh-ish+1) @@ -1366,8 +1363,11 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1421,8 +1421,11 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1478,7 +1481,7 @@ end subroutine int_spec_vol_dp_generic_pcm !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & dP_neglect, bathyP, HI, EOS, US, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) + intp_dza, intx_dza, inty_dza, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the top of the layer [C ~> degC] @@ -1518,8 +1521,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, optional, intent(inout) :: inty_dza !< The integral in y of the difference between !! the geopotential anomaly at the top and bottom of the layer divided !! by the y grid spacing [L2 T-2 ~> m2 s-2] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1556,6 +1559,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state @@ -1563,8 +1567,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) @@ -1607,8 +1612,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! weighting. Note: To work in terrain following coordinates we could ! offset this distance by the layer thickness to replicate other models. hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1668,8 +1676,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! hydrostatic consistency. For large hWght we bias the interpolation ! of T,S along the top and bottom integrals, like thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1726,6 +1737,133 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, end subroutine int_spec_vol_dp_generic_plm +!> Diagnose the fractional mass weighting in a layer that might be used with a Boussinesq calculation. +subroutine diagnose_mass_weight_Z(z_t, z_b, dz_neglect, bathyT, HI, MassWt_u, MassWt_v) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + + ! Local variables + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + if (present(MassWt_u)) then + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo + endif + + if (present(MassWt_v)) then + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo + endif + +end subroutine diagnose_mass_weight_Z + + +!> Diagnose the fractional mass weighting in a layer that might be used with a non-Boussinesq calculation. +subroutine diagnose_mass_weight_p(p_t, p_b, dP_neglect, bathyP, HI, MassWt_u, MassWt_v) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] + real, intent(in) :: dP_neglect ! Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + + ! Local variables + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + if (present(MassWt_u)) then + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo + endif + + if (present(MassWt_v)) then + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo + endif + +end subroutine diagnose_mass_weight_p + !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & rho_ref, G_e, EOS, US, P_b, z_out, z_tol) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 7a9de49573..0180cdd2c0 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1226,7 +1226,7 @@ end function EOS_domain !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1261,8 +1261,8 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] @@ -1280,20 +1280,20 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, MassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_FULL) call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_REDUCED) call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default @@ -1306,7 +1306,7 @@ end subroutine analytic_int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1343,8 +1343,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables @@ -1366,11 +1366,11 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & rho_scale*EOS%Rho_T0_S0, dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp) else call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp) endif case (EOS_WRIGHT) rho_scale = EOS%kg_m3_to_R @@ -1378,12 +1378,12 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_FULL) rho_scale = EOS%kg_m3_to_R @@ -1391,12 +1391,12 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_REDUCED) rho_scale = EOS%kg_m3_to_R @@ -1404,12 +1404,12 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 8b6d6495d1..e71ae1791d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -380,7 +380,7 @@ end subroutine EoS_fit_range_buggy_Wright !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -417,8 +417,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -517,13 +517,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & endif ; endif do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + ! if (do_massWeight) then + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if MassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if MassWghtInterp is present and true.") + ! endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) @@ -640,7 +640,7 @@ end subroutine int_density_dz_wright !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -678,8 +678,8 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -726,6 +726,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -762,14 +763,15 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set +! if (do_massWeight) then ! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") +! "bathyP must be present if MassWghtInterp is present and true.") ! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif +! "dP_neglect must be present if MassWghtInterp is present and true.") +! endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -794,8 +796,11 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -835,8 +840,11 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 31b82e6190..73956d18fd 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -394,7 +394,7 @@ end subroutine EoS_fit_range_Wright_full !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -431,8 +431,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -531,13 +531,13 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & endif ; endif do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + ! if (do_massWeight) then + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if MassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if MassWghtInterp is present and true.") + ! endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -653,7 +653,7 @@ end subroutine int_density_dz_wright_full !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -691,8 +691,8 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -740,6 +740,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -776,14 +777,15 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set +! if (do_massWeight) then ! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") +! "bathyP must be present if MassWghtInterp is present and true.") ! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif +! "dP_neglect must be present if MassWghtInterp is present and true.") +! endif ! alpha = (lambda + al0*(pressure + p0)) / (pressure + p0) do j=jsh,jeh ; do i=ish,ieh @@ -809,8 +811,11 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -851,8 +856,11 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 65bdb9e521..835e3ecd26 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -396,7 +396,7 @@ end subroutine EoS_fit_range_Wright_red !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & - useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -433,8 +433,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -533,13 +533,13 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & endif ; endif do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + ! if (do_massWeight) then + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if MassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if MassWghtInterp is present and true.") + ! endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -655,7 +655,7 @@ end subroutine int_density_dz_wright_red !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & - useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -693,8 +693,8 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure @@ -742,6 +742,7 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -778,14 +779,15 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set +! if (do_massWeight) then ! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") +! "bathyP must be present if MassWghtInterp is present and true.") ! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif +! "dP_neglect must be present if MassWghtInterp is present and true.") +! endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -811,8 +813,11 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -853,8 +858,11 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 8984fbca88..4ecf525abc 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -258,7 +258,7 @@ end subroutine set_params_linear !! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, dz_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -300,8 +300,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. @@ -328,13 +328,13 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & js = HI%jsc ; je = HI%jec do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + ! if (do_massWeight) then + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if MassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if MassWghtInterp is present and true.") + ! endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) @@ -429,7 +429,7 @@ end subroutine int_density_dz_linear !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -471,8 +471,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] @@ -488,6 +488,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -497,14 +498,15 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. + do_massWeight = .false. ; massWeight_bug = .false. + if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set +! if (do_massWeight) then ! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") +! "bathyP must be present if MassWghtInterp is present and true.") ! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif +! "dP_neglect must be present if MassWghtInterp is present and true.") +! endif do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) @@ -520,8 +522,11 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) @@ -565,8 +570,11 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) From 90749f30ff2bc685fc7647650d9bf5757e0b8562 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 31 Jul 2024 11:16:44 -0400 Subject: [PATCH 064/128] Fix logic for reading parameter in MOM_tracer_advect.F90 We had random behavior in the doc files because the logical `CS%useHuynh` was not set when using the PLM scheme. --- src/tracer/MOM_tracer_advect.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e927f2f89d..700422fdf9 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -1133,14 +1133,16 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) "Unknown TRACER_ADVECTION_SCHEME = "//trim(mesg)) end select - if (CS%useHuynh) then - call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & + if (CS%usePPM) then + if (CS%useHuynh) then + call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & CS%useHuynhStencilBug, & desc="If true, use a stencil width of 2 in PPM:H3 tracer advection. " & // "This is incorrect and will produce regressions in certain " & // "configurations, but may be required to reproduce results in " & // "legacy simulations.", & default=.false.) + endif endif id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) From 87a0c618792378f17d145a03165be18dd341be4e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 24 Jul 2024 20:46:51 -0400 Subject: [PATCH 065/128] Removes remap_via_sub_cells(), after copying code into remapping_core_h() This commit addresses a `\todo` added in NOAA-GFDL/MOM6#662, namely that the functions remap_via_sub_cells() and remap_via_sub_cells_om4() could, and should, be moved up into remapping_core_h(), as well as into the obsolete remapping_core_w(). In that PR, the function remap_via_sub_cells() had been modularized into three other functions, and the near-duplicatem remap_via_sub_cells_om4(), called the two of the same functions as well as an out-of-date version of the third function. Since the reampping_core_h() function calls is already brief, calling one function in addition to remap_via_sub_cells(), and since remap_via_sub_cells() is only called from remapping_core_*(), we can remove a level of call-tree depth depth by copying remap_via_sub_grid() into reampping_core_h() and removing the unused function(s). --- src/ALE/MOM_remapping.F90 | 283 +++++++++++++++----------------------- 1 file changed, 114 insertions(+), 169 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 364a322f0f..4495e4a170 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -181,8 +181,7 @@ end subroutine extract_member_remapping_CS !! !! \todo Remove h_neglect argument by moving into remapping_CS !! \todo Remove PCM_cell argument by adding new method in Recon1D class -!! \todo Inline the two versions of remap_via_sub_cells() in remapping_core_h() to eliminate remap_via_sub_cells() -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, net_err, 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 [H] @@ -196,10 +195,24 @@ 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] + real, optional, intent(out) :: net_err !< Error in total column [A 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 + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] @@ -218,20 +231,55 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) - ! This calls the OM4 version of the remapmping algorithms - call remap_via_sub_cells_om4( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & n1, h1, u1, iMethod, uh_err, "remapping_core_h") else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) - 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 ) + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err endif + if (present(net_err)) net_err = uh_err + end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 @@ -251,6 +299,19 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed !! for the purpose of edge value !! calculations in the same units as h0 [H]. ! Local variables + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] @@ -277,10 +338,26 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed h1(k) = max( 0., dx(k+1) - dx(k) ) 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 ) -! 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 ) + + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & n1, h1, u1, iMethod, uh_err, "remapping_core_w") @@ -490,118 +567,6 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & end subroutine check_reconstructions_1d -!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating -!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -!! -!! This uses a buggy remap_via_sub_cells_om4() that produces the wrong value for -!! bottom layers that do not match the same total depth of the water column. -subroutine remap_via_sub_cells_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] - real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] - real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] - integer, intent(in) :: method !< Remapping scheme to use - logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded - real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] - real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] - ! Local variables - real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] - real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] - real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] - integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell - integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell - integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell - integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell - real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] - integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell - integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - real :: u02_err ! Integrated reconstruction error estimates [H A] - - ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids - call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & - isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - - ! Loop over each sub-cell to calculate average/integral values within each sub-cell. - ! Uses: h_sub, h0_eff, isub_src - ! Sets: u_sub, uh_sub - call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & - h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & - method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) - - ! Loop over each target cell summing the integrals from sub-cells within the target cell. - ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub - ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) - - ! Include the error remapping from source to sub-cells in the estimate of total remapping error - uh_err = uh_err + u02_err - -end subroutine remap_via_sub_cells_om4 - -!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating -!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -!! -!! \todo Remove h0_eff which is not needed -!! \todo Undo force_bounds_in_target when switching to Recon1D class -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] - real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] - real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] - integer, intent(in) :: method !< Remapping scheme to use - logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded - real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] - real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] - ! Local variables - real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] - real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] - real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] - integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell - integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell - integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell - integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell - real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] - integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell - integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - real :: u02_err ! Integrated reconstruction error estimates [H A] - - ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids - call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & - isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) - - ! Loop over each sub-cell to calculate average/integral values within each sub-cell. - ! Uses: h_sub, h0_eff, isub_src - ! Sets: u_sub, uh_sub - call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & - isrc_start, isrc_end, isrc_max, isub_src, & - method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) - - ! Loop over each target cell summing the integrals from sub-cells within the target cell. - ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub - ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) - - ! Include the error remapping from source to sub-cells in the estimate of total remapping error - uh_err = uh_err + u02_err - -end subroutine remap_via_sub_cells - !> Returns the intersection of source and targets grids along with and auxiliary lists or indices. !! !! For source grid with thicknesses h0(1:n0) and target grid with thicknesses h1(1:n1) the intersection @@ -778,7 +743,7 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & tgt_has_volume = .false. endif else - stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' + stop 'intersect_src_tgt_grids: THIS SHOULD NEVER HAPPEN!' endif enddo @@ -1666,21 +1631,16 @@ logical function remapping_unit_tests(verbose) ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call initialize_remapping(CS, 'PPM_H4', force_bounds_in_subcell=.false., answer_date=answer_date) - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, h2, INTEGRATION_PPM, .false., u2, err ) - call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remap_via_sub_cells() 2') + call remapping_core_h( CS, n0, h0, u0, n2, h2, u2, net_err=err ) + call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remapping_core_h() 2') - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) - call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remap_via_sub_cells() 3') + call remapping_core_h( CS, n0, h0, u0, 6, (/.125,.125,.125,.125,.125,.125/), u2, net_err=err ) + call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remapping_core_h() 3') - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) - call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') + call remapping_core_h( CS, n0, h0, u0, 3, (/2.25,1.5,1./), u2, net_err=err ) + call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remapping_core_h() 4') deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) call end_remapping(CS) @@ -1768,7 +1728,7 @@ logical function remapping_unit_tests(verbose) deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) ! ============================================================== - ! This section tests the components of remap_via_sub_cells() + ! This section tests the components of remapping_core_h() ! ============================================================== if (verbose) write(test%stdout,*) ' - - - - - remapping algororithm tests - - - - -' @@ -2056,64 +2016,49 @@ logical function remapping_unit_tests(verbose) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) ! ============================================================ - ! This section tests remap_via_sub_cells() + ! This section tests remapping_core_h() ! ============================================================ - if (verbose) write(test%stdout,*) '- - - - - - - - - - remap_via_sub_cells() tests - - - - - - - - -' + if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' - allocate(ppoly0_E(4,2), ppoly0_S(4,2), ppoly0_coefs(4,3), u2(2)) + allocate(u2(2)) - ! These tests has vanished top and bottom layers with a linear profile - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, 0.) - ! Reconstruction has piecewise constant 5 and 1 for top and bottom layers respectively - ! but which are vanished so give no wieght to integrals. - ! Interface values are 5, 5, 3, 1, 1. - call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - call test%real_arr(4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + call initialize_remapping(CS, 'PLM', force_bounds_in_subcell=.false., answer_date=answer_date) ! Remapping to just the two interior layers yields the same values as u_src(2:3) - call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11 om4') - call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') ! Remapping to two layers that are deeper. For the bottom layer of thickness 4, ! the first 1/4 has average 2, the remaining 3/4 has the bottom edge value or 1 ! yield ing and average or 1.25 - call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14 om4') - call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14') ! Remapping to two layers with lowest layer not reach the bottom. ! Here, the bottom layer samples top half of source yeilding 2.5. ! Note: OM4 used the value as if the target layer was the same thickness as source. - call remap_via_sub_cells_om4(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0440->h=42 om4 (with known bug)') - call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) call test%real_arr(2, u2, (/4.,2.5/), 'PLM: remapped h=0440->h=42') ! Remapping to two layers with no layers sampling the bottom source layer ! The first layer samples the top half of u1, yielding 4.5 ! The second layer samples the next quarter of u1, yielding 3.75 - call remap_via_sub_cells_om4(4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/2.,2./), INTEGRATION_PLM, .false., u2, err) + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), 2, (/2.,2./), u2) call test%real_arr(2, u2, (/4.5,3.5/), 'PLM: remapped h=0880->h=21 om4 (with known bug)') - call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & - 2, (/2.,1./), INTEGRATION_PLM, .false., u2, err) + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/2.,1./), u2) call test%real_arr(2, u2, (/4.5,3.75/), 'PLM: remapped h=0440->h=21') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) - - ! ============================================================ - ! This section tests remapping_core_h() - ! ============================================================ - if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' + deallocate(u2) ! Profile 0: 8 layers, 1x top/2x bottom vanished, and the rest with thickness 1.0, total depth 5, u(z) = 1 + z n0 = 8 From 0344a76377b6708881ee994e3e5fab57308901d8 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 1 Aug 2024 10:01:14 -0400 Subject: [PATCH 066/128] Add gustless Tau to fluxes extracted from IOB by FMS cap. - Gustless Tau is needed for Langmuir turbulence parameterization (part of ePBL) in non-Boussinesq mode. - Adds new option to populate Gustless Tau field when present in fluxes control structure as part of extract_IOB_stresses, which is used in convert_IOB_to_fluxes in the FMS cap. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 28 ++++++++++++++----- 1 file changed, 21 insertions(+), 7 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 1e56486329..825f0cc29a 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -635,9 +635,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif ! Set the wind stresses and ustar. - if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag)) then + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag) & + .and. associated(fluxes%tau_mag_gustless) ) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & - mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless) + mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless, & + gustless_mag_tau=fluxes%tau_mag_gustless) else if (associated(fluxes%ustar)) & call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) @@ -645,6 +647,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) if (associated(fluxes%tau_mag)) & call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=fluxes%tau_mag) + if (associated(fluxes%tau_mag_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_mag_tau=fluxes%tau_mag_gustless) endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -908,7 +912,7 @@ end subroutine convert_IOB_to_forces !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & - gustless_ustar, mag_tau, tau_halo) + gustless_ustar, mag_tau, gustless_mag_tau, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -931,6 +935,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZI_(G),SZJ_(G)), & optional, intent(inout) :: mag_tau !< The magintude of the wind stress at tracer points !! including subgridscale variability and gustiness [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: gustless_mag_tau !< The magintude of the wind stress at tracer points + !! without any contributions from gustiness [R Z L T-2 ~> Pa] integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables @@ -947,7 +954,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - logical :: do_ustar, do_gustless, do_tau_mag + logical :: do_ustar, do_gustless, do_tau_mag, do_gustless_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo @@ -960,7 +967,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, IRho0 = US%L_to_Z / CS%Rho0 stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier - do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) ; do_tau_mag = present(mag_tau) + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + do_tau_mag = present(mag_tau) ; do_gustless_tau_mag = present(gustless_mag_tau) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & @@ -973,7 +981,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar .or. do_tau_mag .or. do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) & + .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 @@ -1053,7 +1062,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif ! endif for extracting wind stress fields with various staggerings endif - if (do_ustar .or. do_tau_mag .or. do_gustless) then + if (do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) then ! Set surface friction velocity directly or as a function of staggering. ! ustar is required for the bulk mixed layer formulation and other turbulent mixing ! parametizations. The background gustiness (for example with a relatively small value @@ -1071,6 +1080,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif if (do_tau_mag) & mag_tau(i,j) = gustiness + US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + if (do_gustless_tau_mag) & + gustless_mag_tau(i,j) = US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) if (do_ustar) & ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif @@ -1097,6 +1108,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1110,6 +1122,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1132,6 +1145,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else From da59eb0c7a4964813c945683a2cecc56208b7cb8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 25 Jul 2024 14:10:17 -0400 Subject: [PATCH 067/128] Adds new pre-defined coordinate WOA09INT In OM4, we use the "WOA09" coordinate for diagnostic z* output. This grid was based on WOA09 but not exact because the WOA09 grid is not smooth. We tried to construct a grid such that layer centers matched the depths of WOA09 but this was not possible for six layers. As an alternative, this new coordinate, "WOA09INT", uses the WOA09 depths as interfaces so that the layer centers are always midway between the WOA09 depths. To compare with WOA09 directly, WOA data now should be interpolated but this is a simple half-half averaging. --- src/ALE/MOM_regridding.F90 | 60 +++++++++++++++++++++++++++++--------- 1 file changed, 47 insertions(+), 13 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 43d3f65a5e..7ac8cbb4a0 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -226,12 +226,22 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths ! [H ~> m or kg m-2] or other units real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] - !> Thicknesses [m] that give level centers corresponding to table 2 of WOA09 - real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & - 37.5, 50., 50., 75., 100., 100., 100., 100., & - 100., 100., 100., 100., 100., 100., 100., 175., & - 250., 375., 500., 500., 500., 500., 500., 500., & - 500., 500., 500., 500., 500., 500., 500., 500. /) + ! Thicknesses [m] that give level centers approximately corresponding to table 2 of WOA09 + ! These are approximate because the WOA09 depths are not smoothly spaced. Levels + ! 1, 4, 5, 9, 12, 24, and 36 are 2.5, 2.5, 1.25 12.5, 37.5 and 62.5 m deeper than WOA09 + ! but all others are identical. + real, dimension(40) :: woa09_dz_approx = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & + 37.5, 50., 50., 75., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 175., & + 250., 375., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500., 500. /) + ! These are the actual spacings [m] between WOA09 depths which, if used for layer thickness, places + ! the interfaces at the WOA09 depths. + real, dimension(39) :: woa09_dzi = (/ 10., 10., 10., 20., 25., 25., 25., 25., & + 50., 50., 50., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 250., & + 250., 500., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500. /) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -325,6 +335,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m " by a comma or space, e.g. FILE:lev.nc,dz\n"//& " or FILE:lev.nc,interfaces=zw\n"//& " WOA09[:N] - the WOA09 vertical grid (approximately)\n"//& + " WOA09INT[:N] - layers spanned by the WOA09 depths\n"//& " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& " HYBRID:string - read from a file. The string specifies\n"//& " the filename and two variable names, separated\n"//& @@ -458,18 +469,41 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) endif + elseif (index(trim(string),'WOA09INT')==1) then + if (len_trim(string)==8) then ! string=='WOA09INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa09_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa09_dzi(ke) + enddo + elseif (index(trim(string),'WOA09INT:')==1) then ! string starts with 'WOA09INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA09INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa09_dzi)) dz(ke) = dz_extra elseif (index(trim(string),'WOA09')==1) then - if (len_trim(string)==5) then + if (len_trim(string)==5) then ! string=='WOA09' tmpReal = 0. ; ke = 0 ; dz_extra = 0. do while (tmpReal size(woa09_dz)) then + if (ke > size(woa09_dz_approx)) then dz_extra = maximum_depth - tmpReal exit endif - tmpReal = tmpReal + woa09_dz(ke) + tmpReal = tmpReal + woa09_dz_approx(ke) enddo - elseif (index(trim(string),'WOA09:')==1) then + elseif (index(trim(string),'WOA09:')==1) then ! string starts with 'WOA09:' if (len_trim(string)==6) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Expected string of form "WOA09:N" but got "'//trim(string)//'".') ke = extract_integer(string(7:len_trim(string)),'',1) @@ -477,10 +511,10 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m 'For "WOA05:N" N must 0 size(woa09_dz)) dz(ke) = dz_extra + if (ke > size(woa09_dz_approx)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized coordinate configuration"//trim(string)) From fee3281c28443d3ced30814df217c8066df5a297 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 25 Jul 2024 15:26:13 -0400 Subject: [PATCH 068/128] Adds new pre-defined coordinate WOA23INT Encoded the WOA23 depth spacing to use for finer resolution diagnostic grid. As for WOA09INT, the WOA23 depths are used as interface positions requiring the WOA23 data to be interpolated (half-half averaging) to this WOA23INT grid. --- src/ALE/MOM_regridding.F90 | 42 +++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 7ac8cbb4a0..0d325292f5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -230,7 +230,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! These are approximate because the WOA09 depths are not smoothly spaced. Levels ! 1, 4, 5, 9, 12, 24, and 36 are 2.5, 2.5, 1.25 12.5, 37.5 and 62.5 m deeper than WOA09 ! but all others are identical. - real, dimension(40) :: woa09_dz_approx = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & + real, dimension(40) :: woa09_dz_approx = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & 37.5, 50., 50., 75., 100., 100., 100., 100., & 100., 100., 100., 100., 100., 100., 100., 175., & 250., 375., 500., 500., 500., 500., 500., 500., & @@ -242,6 +242,22 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m 100., 100., 100., 100., 100., 100., 100., 250., & 250., 500., 500., 500., 500., 500., 500., 500., & 500., 500., 500., 500., 500., 500., 500. /) + ! These are the spacings [m] between WOA23 depths from table 3 of + ! https://www.ncei.noaa.gov/data/oceans/woa/WOA13/DOC/woa13documentation.pdf + real, dimension(136) :: woa23_dzi = (/ 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 25., 25., 25., 25., 25., 25., 25., 25., 25., 25., & + 25., 25., 25., 25., 25., 25., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100. /) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -336,6 +352,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m " or FILE:lev.nc,interfaces=zw\n"//& " WOA09[:N] - the WOA09 vertical grid (approximately)\n"//& " WOA09INT[:N] - layers spanned by the WOA09 depths\n"//& + " WOA23INT[:N] - layers spanned by the WOA23 depths\n"//& " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& " HYBRID:string - read from a file. The string specifies\n"//& " the filename and two variable names, separated\n"//& @@ -492,6 +509,29 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m dz(k) = woa09_dzi(k) enddo if (ke > size(woa09_dzi)) dz(ke) = dz_extra + elseif (index(trim(string),'WOA23INT')==1) then + if (len_trim(string)==8) then ! string=='WOA23INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa23_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa23_dzi(ke) + enddo + elseif (index(trim(string),'WOA23INT:')==1) then ! string starts with 'WOA23INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA23INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa23_dzi)) dz(ke) = dz_extra elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then ! string=='WOA09' tmpReal = 0. ; ke = 0 ; dz_extra = 0. From e30a6e7118171737404bb79265f9d82058e0593a Mon Sep 17 00:00:00 2001 From: Wenda Zhang <42078272+Wendazhang33@users.noreply.github.com> Date: Fri, 2 Aug 2024 12:06:57 -0400 Subject: [PATCH 069/128] Fix bugs in setting GxSpV_u and GxSpV_v in MOM_isopycnal_slopes (#701) * Fix bugs in setting GxSpV_u and GxSpV_v in MOM_isopycnal_slopes - In the previous version, GxSpV_u and GxSpV_v were only set when use_EOS was true - Now initialize GxSpV_u and GxSpV_v to be G_Rho0 * Fixed an OMP issue in MOM_isopycnal_slopes --- src/core/MOM_isopycnal_slopes.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index bc0a81e40e..179b082f1d 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -240,15 +240,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ; enddo enddo + do I=is-1,ie + GxSpV_u(I) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,h_neglect2, & !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & !$OMP local_open_u_BC,dzu,OBC,use_stanley) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_u, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,l_seg) + !$OMP drdx,mag_grad2,slope,l_seg) & + !$OMP firstprivate(GxSpV_u) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -270,10 +274,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) enddo - else - do I=is-1,ie - GxSpV_u(I) = G_Rho0 - enddo endif endif endif @@ -384,6 +384,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ! I enddo ; enddo ! end of j-loop + do i=is,ie + GxSpV_v(i) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect, & @@ -391,10 +394,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP dzv,local_open_v_BC,OBC,use_stanley) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_v, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,l_seg) + !$OMP drdy,mag_grad2,slope,l_seg) & + !$OMP firstprivate(GxSpV_v) do J=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -416,10 +420,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) enddo - else - do i=is,ie - GxSpV_v(i) = G_Rho0 - enddo endif endif endif From 906d96aa3c9bf5041e9b1817cda19d39f26193ca Mon Sep 17 00:00:00 2001 From: Theresa Morrison Date: Fri, 2 Aug 2024 13:16:44 -0400 Subject: [PATCH 070/128] Add option to use non-surface density in MLD_003 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A new parameter is added to diagnoseMLDbyDensityDifference that allows a user to specify a reference for the surface density that is not the top model layer. This feature should make the MLD_003 diagnostic more consistent with the de Boyer Montégut MLD climatology. In addition, new diagnostics have been added to save the actual depth of the density used and the "surface" density used in the MLD calculation. These options have only been added for the MLD_003 option. --- .../vertical/MOM_diabatic_aux.F90 | 89 +++++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 19 +++- 2 files changed, 91 insertions(+), 17 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index aa31024b24..59b37860ab 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -679,7 +679,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_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) + ref_h_mld, id_ref_z, id_ref_rho, id_N2subML, id_MLDsq, dz_subML) type(ocean_grid_type), intent(in) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -690,6 +690,9 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, !! available thermodynamic fields. real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + real, intent(in) :: ref_h_mld !< Depth of the calculated "surface" densisty [Z ~> m] + integer, intent(in) :: id_ref_z !< Handle (ID) of reference depth diagnostic + integer, intent(in) :: id_ref_rho !< Handle (ID) of reference density diagnostic integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML @@ -698,6 +701,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: hRef_MLD ! Reference depth [Z ~> m]. real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. @@ -706,6 +710,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: z_ref_diag ! The actual depth of the reference density [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. @@ -716,6 +721,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] real :: aFac ! A nondimensional factor [nondim] real :: ddRho ! A density difference [R ~> kg m-3] + real :: dddpth ! A depth difference [Z ~> m] + real :: rhoSurf_k, rhoSurf_km1 ! Desisty in the layers below and above the target reference depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: rhoSurf_2d ! The density that is considered the "surface" when calculating + ! the MLD. It can be saved as a diagnostic [R ~> kg m-3]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ @@ -737,24 +746,72 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - pRef_MLD(:) = 0.0 + hRef_MLD(:) = ref_h_mld + pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld + z_ref_diag(:,:) = 0. + EOSdom(:) = EOS_domain(G%HI) do j=js,je ! Find the vertical distances across layers. call thickness_to_dz(h, tv, dZ_2d, j, G, GV) - do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) - do i=is,ie - deltaRhoAtK(i) = 0. - MLD(i,j) = 0. - if (id_N2>0) then - subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 - T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 - N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. - endif - enddo + if (pRef_MLD(is) /= 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! Depth of center of surface layer + if (dZ(i) >= hRef_MLD(i)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + dddpth = dZ(i) - dZm1(i) + if ((rhoSurf(i) == 0.) .and. & + (dZm1(i) < hRef_MLD(i)) .and. (dZ(i) >= hRef_MLD(i))) then + aFac = ( hRef_MLD(i) - dZm1(i) ) / dddpth + z_ref_diag(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + call calculate_density(tv%T(i,j,k) , tv%S(i,j,k) , pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + call calculate_density(tv%T(i,j,k-1), tv%S(i,j,k-1), pRef_MLD(i), rhoSurf_km1, tv%eqn_of_state) + rhoSurf(i) = (rhoSurf_k * aFac + rhoSurf_km1 * (1. - aFac)) + H_subML(i) = h(i,j,k) + elseif ((rhoSurf(i) == 0.) .and. (k >= nz)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + enddo + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! reset dZ to surface depth + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + elseif (pRef_MLD(is) == 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + do i=is,ie + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + endif + do k=2,nz do i=is,ie dZm1(i) = dZ(i) ! Depth of center of layer K-1 @@ -823,6 +880,9 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) + if ((id_ref_z > 0) .and. (pRef_MLD(is)/=0.)) call post_data(id_ref_z, z_ref_diag , diagPtr) + if (id_ref_rho > 0) call post_data(id_ref_rho, rhoSurf_2d , diagPtr) + end subroutine diagnoseMLDbyDensityDifference !> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. @@ -1964,5 +2024,4 @@ end subroutine diabatic_aux_end !! salinities due to the application of the surface forcing. It may also calculate the implied !! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite !! vertical resolution in the surface layers. - end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 18bbc45e13..9386b599a7 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -175,6 +175,8 @@ module MOM_diabatic_driver real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] + real :: ref_h_mld = 0.0 !< The depth of the "surface" density used in a difference mixed based + !! MLD calculation [Z ~> m]. !>@{ Diagnostic IDs integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic @@ -183,6 +185,7 @@ module MOM_diabatic_driver 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_003_zr = -1, id_MLD_003_rr = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 ! These are handles to diagnostics that are only available in non-ALE layered mode. @@ -479,13 +482,16 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & call enable_averages(dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if (CS%id_MLD_user > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& @@ -3273,6 +3279,15 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & 'Mixed layer depth (used defined)', units='m', conversion=US%Z_to_m) + if (CS%id_MLD_003 > 0) then + call get_param(param_file, mdl, "HREF_FOR_MLD", CS%ref_h_mld, & + "Reference depth used to calculate the potential density used to find the mixed layer depth "//& + "based on a delta rho = 0.03 kg/m3.", units='m', default=0.0, scale=US%m_to_Z) + CS%id_MLD_003_zr = register_diag_field('ocean_model', 'MLD_003_refZ', diag%axesT1, Time, & + 'Depth of reference density for MLD (delta rho = 0.03)', units='m', conversion=US%Z_to_m) + CS%id_MLD_003_rr = register_diag_field('ocean_model', 'MLD_003_refRho', diag%axesT1, Time, & + 'Reference density for MLD (delta rho = 0.03)', units='kg/m3', conversion=US%R_to_kg_m3) + endif endif call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & "The density difference used to determine a diagnostic mixed "//& From f1ba822636bb937be1828a3e4f1e0e2155ea8b6a Mon Sep 17 00:00:00 2001 From: Theresa Morrison Date: Fri, 2 Aug 2024 13:20:17 -0400 Subject: [PATCH 071/128] Move MLD Diagnostics out of MOM_diabatic_aux.F90 Move the calculation of density difference and energy difference based MLD diagnostics out of MOM_diabatic_aux and into a new module MOM_diagnose_MLD.F90. Because this new module includes only the calculation of mixed layer depths that will be primarily used as diagnostics, it will be in the diagnostics subfolder. This change will allow the diagnose MLD routines to be used in the generic tracers. --- src/diagnostics/MOM_diagnose_MLD.F90 | 487 ++++++++++++++++++ .../vertical/MOM_diabatic_aux.F90 | 451 ---------------- .../vertical/MOM_diabatic_driver.F90 | 2 +- 3 files changed, 488 insertions(+), 452 deletions(-) create mode 100644 src/diagnostics/MOM_diagnose_MLD.F90 diff --git a/src/diagnostics/MOM_diagnose_MLD.F90 b/src/diagnostics/MOM_diagnose_MLD.F90 new file mode 100644 index 0000000000..29b66ef6ac --- /dev/null +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -0,0 +1,487 @@ +!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!! tendency due to surface flux divergence. +module MOM_diagnose_mld + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data +use MOM_diag_mediator, only : diag_ctrl +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! 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 +!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. +!> 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, & + ref_h_mld, id_ref_z, id_ref_rho, id_N2subML, id_MLDsq, dz_subML) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + real, intent(in) :: ref_h_mld !< Depth of the calculated "surface" densisty [Z ~> m] + integer, intent(in) :: id_ref_z !< Handle (ID) of reference depth diagnostic + integer, intent(in) :: id_ref_rho !< Handle (ID) of reference density diagnostic + integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification + integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] + + ! Local variables + real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: hRef_MLD ! Reference depth [Z ~> m]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: z_ref_diag ! The actual depth of the reference density [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] + real :: aFac ! A nondimensional factor [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + real :: dddpth ! A depth difference [Z ~> m] + real :: rhoSurf_k, rhoSurf_km1 ! Desisty in the layers below and above the target reference depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: rhoSurf_2d ! The density that is considered the "surface" when calculating + ! the MLD. It can be saved as a diagnostic [R ~> kg m-3]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ + + id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq + + id_N2 = -1 + if (present(id_N2subML)) then + if (present(dz_subML)) then + id_N2 = id_N2subML + dZ_sub_ML = dz_subML + else + call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& + "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& + "the distance over which to calculate that distance must also be provided.") + endif + endif + + gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + hRef_MLD(:) = ref_h_mld + pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld + z_ref_diag(:,:) = 0. + + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + if (pRef_MLD(is) /= 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! Depth of center of surface layer + if (dZ(i) >= hRef_MLD(i)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + dddpth = dZ(i) - dZm1(i) + if ((rhoSurf(i) == 0.) .and. & + (dZm1(i) < hRef_MLD(i)) .and. (dZ(i) >= hRef_MLD(i))) then + aFac = ( hRef_MLD(i) - dZm1(i) ) / dddpth + z_ref_diag(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + call calculate_density(tv%T(i,j,k) , tv%S(i,j,k) , pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + call calculate_density(tv%T(i,j,k-1), tv%S(i,j,k-1), pRef_MLD(i), rhoSurf_km1, tv%eqn_of_state) + rhoSurf(i) = (rhoSurf_k * aFac + rhoSurf_km1 * (1. - aFac)) + H_subML(i) = h(i,j,k) + elseif ((rhoSurf(i) == 0.) .and. (k >= nz)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + enddo + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! reset dZ to surface depth + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + elseif (pRef_MLD(is) == 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + do i=is,ie + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + endif + + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + enddo + + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. + if (id_N2>0) then + do i=is,ie + if (MLD(i,j) == 0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) + N2_region_set(i) = .true. + endif + endif + enddo ! i-loop + endif ! id_N2>0 + + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + do i = is, ie + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & + (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then + aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + endif + if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 + enddo ! i-loop + enddo ! k-loop + do i=is,ie + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom + enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! 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.0) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) + endif ; enddo + endif + enddo ! j-loop + + if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) + if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) + if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) + + if ((id_ref_z > 0) .and. (pRef_MLD(is)/=0.)) call post_data(id_ref_z, z_ref_diag , diagPtr) + if (id_ref_rho > 0) call post_data(id_ref_rho, rhoSurf_2d , diagPtr) + +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_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 + ! // + ! *Note that gravity is assumed constant everywhere and divided out of all calculations. + ! + ! This code has been written to step through the columns layer by layer, summing the PE + ! change inferred by mixing the layer with all layers above. When the change exceeds a + ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far + ! into this layer the threshold PE change occurs (assuming constant density layers). + ! This is expressed here via solving the function F(X) = 0 where: + ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) + ! + Ca2*X^2 + Cb2*X + Cc2) + ! where all coefficients are determined by the previous mixed layer depth, the + ! density of the previous mixed layer, the present layer thickness, and the present + ! layer density. This equation is worked out by computing the total PE assuming constant + ! density in the mixed layer as well as in the remaining part of the present layer that is + ! not mixed. + ! To solve for X in this equation a Newton's method iteration is employed, which + ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather + ! linear for PE change with increasing X. + ! Input parameters: + integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer + ! depth calculation [R L2 T-2 ~> Pa] + real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] + + real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy + ! for the energy used to mix to the diagnosed depth [nondim] + real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] + real :: PE ! The cumulative potential energy of the unmixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] + real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth + ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] + + ! These are all temporary variables used to shorten the expressions in the iterations. + real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] + real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] + real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] + real :: C, D ! A depth squared [Z2 ~> m2] + real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] + real :: Cd ! A density times a depth cubed [R Z3 ~> kg] + real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] + real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] + real :: Hx ! The vertical integral depth [Z ~> m] + real :: iHx ! The inverse of Hx [Z-1 ~> m-1] + real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] + real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] + real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] + real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] + real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: IT, iM + integer :: i, j, is, ie, js, je, k, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + pRef_MLD(:) = 0.0 + mld(:,:,:) = 0.0 + PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + + do iM=1,3 + PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) + enddo + + MLD(:,:,:) = 0.0 + + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + + Z_int(1) = 0.0 + do k=1,nz + Z_int(K+1) = Z_int(K) - dZ(i,k) + enddo + + do iM=1,3 + + ! Initialize these for each column-wise calculation + PE = 0.0 + RhoDZ_ML = 0.0 + H_ML = 0.0 + RhoDZ_ML_TST = 0.0 + H_ML_TST = 0.0 + PE_Mixed = 0.0 + + do k=1,nz + + ! This is the unmixed PE cumulative sum from top down + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + + ! This is the depth and integral of density + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) + + ! The average density assuming all layers including this were mixed + Rho_ML = RhoDZ_ML_TST/H_ML_TST + + ! The PE assuming all layers including this were mixed + ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 + ! but 0 is a good reference value. + PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) + + ! Check if we supplied enough energy to mix to this layer + if (PE_Mixed_TST - PE <= PE_threshold(iM)) then + H_ML = H_ML_TST + RhoDZ_ML = RhoDZ_ML_TST + + else ! If not, we need to solve where the energy ran out + ! This will be done with a Newton's method iteration: + + R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) + D1 = H_ML ! The thickness of the mixed layer (not including this layer) + R2 = Rho_c(i,k) ! The density of this layer + D2 = dZ(i,k) ! The thickness of this layer + + ! This block could be used to calculate the function coefficients if + ! we don't reference all values to a surface designated as z=0 + ! S = Surface + ! Ca = -(R2) + ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) + ! D = D1**2. - 2.*D1*S + ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) + ! Cd = -(R1*D1*D) + ! Ca2 = R2 + ! Cb2 = R2*(2*D1-2*S) + ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 + ! Cc2 = R2*(D+S**2-C) + ! + ! If the surface is S = 0, it simplifies to: + Ca = -R2 + Cb = -(R1 * D1 + R2 * (2. * D1)) + D = D1**2 + Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) + Cd = -R1 * (D1 * D) + Ca2 = R2 + Cb2 = R2 * (2. * D1) + C = D2**2 + D1**2 + 2. * (D1 * D2) + Cc2 = R2 * (D - C) + + ! First guess for an iteration using Newton's method + X = dZ(i,k) * 0.5 + + IT=0 + do while(IT<10)!We can iterate up to 10 times + ! We are trying to solve the function: + ! F(x) = G(x)/H(x)+I(x) + ! for where F(x) = PE+PE_threshold, or equivalently for where + ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 + ! We also need the derivative of this function for the Newton's method iteration + ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! G and its derivative + Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) + Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) + ! H, its inverse, and its derivative + Hx = D1 + X + iHx = 1. / Hx + Hpx = 1. + ! I and its derivative + Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) + Ipx = 0.5 * (2. * Ca2 * X + Cb2) + + ! The Function and its derivative: + PE_Mixed = Gx * iHx + Ix + Fgx = PE_Mixed - (PE + PE_threshold(iM)) + Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx + + ! Check if our solution is within the threshold bounds, if not update + ! using Newton's method. This appears to converge almost always in + ! one step because the function is very close to linear in most applications. + if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then + X2 = X - Fgx / Fpx + IT = IT + 1 + if (X2 < 0. .or. X2 > dZ(i,k)) then + ! The iteration seems to be robust, but we need to do something *if* + ! things go wrong... How should we treat failed iteration? + ! Present solution: Stop trying to compute and just say we can't mix this layer. + X=0 + exit + else + X = X2 + endif + else + exit! Quit the iteration + endif + enddo + H_ML = H_ML + X + exit! Quit looping through the column + endif + enddo + MLD(i,j,iM) = H_ML + enddo + endif ; enddo + enddo + + if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) + if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) + if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) + +end subroutine diagnoseMLDbyEnergy + +!> \namespace mom_diagnose_mld +!! +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. +!! +!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a +!! density difference criterion, and may also estimate the stratification of the water below +!! this diagnosed mixed layer. +!! +!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy +!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. +!! + +end module MOM_diagnose_mld diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 59b37860ab..dadbf8206e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -33,7 +33,6 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave -public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -675,449 +674,6 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow 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_aux due to its position within the time stepping. -subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & - ref_h_mld, id_ref_z, id_ref_rho, id_N2subML, id_MLDsq, dz_subML) - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - real, intent(in) :: ref_h_mld !< Depth of the calculated "surface" densisty [Z ~> m] - integer, intent(in) :: id_ref_z !< Handle (ID) of reference depth diagnostic - integer, intent(in) :: id_ref_rho !< Handle (ID) of reference density diagnostic - integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification - integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD - real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML - !! or 50 m if missing [Z ~> m] - - ! Local variables - real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: hRef_MLD ! Reference depth [Z ~> m]. - real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] - real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] - real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. - real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. - real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. - real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] - real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. - real, dimension(SZI_(G), SZJ_(G)) :: z_ref_diag ! The actual depth of the reference density [Z ~> m]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. - logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 - ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq - ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. - real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] - real :: aFac ! A nondimensional factor [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - real :: dddpth ! A depth difference [Z ~> m] - real :: rhoSurf_k, rhoSurf_km1 ! Desisty in the layers below and above the target reference depth [R ~> kg m-3]. - real, dimension(SZI_(G), SZJ_(G)) :: rhoSurf_2d ! The density that is considered the "surface" when calculating - ! the MLD. It can be saved as a diagnostic [R ~> kg m-3]. - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ - - id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - - id_N2 = -1 - if (present(id_N2subML)) then - if (present(dz_subML)) then - id_N2 = id_N2subML - dZ_sub_ML = dz_subML - else - call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& - "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& - "the distance over which to calculate that distance must also be provided.") - endif - endif - - gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - hRef_MLD(:) = ref_h_mld - pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld - z_ref_diag(:,:) = 0. - - EOSdom(:) = EOS_domain(G%HI) - do j=js,je - ! Find the vertical distances across layers. - call thickness_to_dz(h, tv, dZ_2d, j, G, GV) - - if (pRef_MLD(is) /= 0.0) then - rhoSurf(:) = 0.0 - do i=is,ie - dZ(i) = 0.5 * dZ_2d(i,1) ! Depth of center of surface layer - if (dZ(i) >= hRef_MLD(i)) then - call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) - rhoSurf(i) = rhoSurf_k - endif - enddo - do k=2,nz - do i=is,ie - dZm1(i) = dZ(i) ! Depth of center of layer K-1 - dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K - dddpth = dZ(i) - dZm1(i) - if ((rhoSurf(i) == 0.) .and. & - (dZm1(i) < hRef_MLD(i)) .and. (dZ(i) >= hRef_MLD(i))) then - aFac = ( hRef_MLD(i) - dZm1(i) ) / dddpth - z_ref_diag(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) - call calculate_density(tv%T(i,j,k) , tv%S(i,j,k) , pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) - call calculate_density(tv%T(i,j,k-1), tv%S(i,j,k-1), pRef_MLD(i), rhoSurf_km1, tv%eqn_of_state) - rhoSurf(i) = (rhoSurf_k * aFac + rhoSurf_km1 * (1. - aFac)) - H_subML(i) = h(i,j,k) - elseif ((rhoSurf(i) == 0.) .and. (k >= nz)) then - call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) - rhoSurf(i) = rhoSurf_k - endif - enddo - enddo - do i=is,ie - dZ(i) = 0.5 * dZ_2d(i,1) ! reset dZ to surface depth - rhoSurf_2d(i,j) = rhoSurf(i) - deltaRhoAtK(i) = 0. - MLD(i,j) = 0. - if (id_N2>0) then - subMLN2(i,j) = 0.0 - dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 - T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 - N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. - endif - enddo - elseif (pRef_MLD(is) == 0.0) then - rhoSurf(:) = 0.0 - do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) - do i=is,ie - rhoSurf_2d(i,j) = rhoSurf(i) - deltaRhoAtK(i) = 0. - MLD(i,j) = 0. - if (id_N2>0) then - subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 - T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 - N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. - endif - enddo - endif - - do k=2,nz - do i=is,ie - dZm1(i) = dZ(i) ! Depth of center of layer K-1 - dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K - enddo - - ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding - ! the cells that extend over at least dz_subML. - if (id_N2>0) then - do i=is,ie - if (MLD(i,j) == 0.0) then ! Still in the mixed layer. - H_subML(i) = H_subML(i) + h(i,j,k) - elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML - T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) - H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. - dH_N2(i) = 0.5 * h(i,j,k) - dZ_N2(i) = 0.5 * dz_2d(i,k) - elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then - dH_N2(i) = dH_N2(i) + h(i,j,k) - dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) - else ! This layer includes the base of the region where N2 is calculated. - T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) - dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) - dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) - N2_region_set(i) = .true. - endif - endif - enddo ! i-loop - endif ! id_N2>0 - - ! Mixed-layer depth, using sigma-0 (surface reference pressure) - do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) - do i = is, ie - deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface - ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) - if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & - (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then - aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho - MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) - endif - if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 - enddo ! i-loop - enddo ! k-loop - do i=is,ie - if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom - enddo - - if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. - do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo - ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then - ! ! Use whatever stratification we can, measured over whatever distance is available? - ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) - ! N2_region_set(i) = .true. - ! 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.0) .and. N2_region_set(i)) then - subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) - endif ; enddo - endif - enddo ! j-loop - - if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) - if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) - if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) - - if ((id_ref_z > 0) .and. (pRef_MLD(is)/=0.)) call post_data(id_ref_z, z_ref_diag , diagPtr) - if (id_ref_rho > 0) call post_data(id_ref_rho, rhoSurf_2d , diagPtr) - -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_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 - ! // - ! *Note that gravity is assumed constant everywhere and divided out of all calculations. - ! - ! This code has been written to step through the columns layer by layer, summing the PE - ! change inferred by mixing the layer with all layers above. When the change exceeds a - ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far - ! into this layer the threshold PE change occurs (assuming constant density layers). - ! This is expressed here via solving the function F(X) = 0 where: - ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) - ! + Ca2*X^2 + Cb2*X + Cc2) - ! where all coefficients are determined by the previous mixed layer depth, the - ! density of the previous mixed layer, the present layer thickness, and the present - ! layer density. This equation is worked out by computing the total PE assuming constant - ! density in the mixed layer as well as in the remaining part of the present layer that is - ! not mixed. - ! To solve for X in this equation a Newton's method iteration is employed, which - ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather - ! linear for PE change with increasing X. - ! Input parameters: - integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - - ! Local variables - real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] - real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] - real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer - ! depth calculation [R L2 T-2 ~> Pa] - real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] - - real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy - ! for the energy used to mix to the diagnosed depth [nondim] - real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] - real :: PE ! The cumulative potential energy of the unmixed water column to a depth - ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth - ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] - real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] - real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth - ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] - real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] - real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] - - ! These are all temporary variables used to shorten the expressions in the iterations. - real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] - real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] - real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] - real :: C, D ! A depth squared [Z2 ~> m2] - real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] - real :: Cd ! A density times a depth cubed [R Z3 ~> kg] - real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] - real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] - real :: Hx ! The vertical integral depth [Z ~> m] - real :: iHx ! The inverse of Hx [Z-1 ~> m-1] - real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] - real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] - real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] - real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] - real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] - - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: IT, iM - integer :: i, j, is, ie, js, je, k, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - pRef_MLD(:) = 0.0 - mld(:,:,:) = 0.0 - PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. - - do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) - enddo - - MLD(:,:,:) = 0.0 - - EOSdom(:) = EOS_domain(G%HI) - - do j=js,je - ! Find the vertical distances across layers. - call thickness_to_dz(h, tv, dz, j, G, GV) - - do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) - enddo - - do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - - Z_int(1) = 0.0 - do k=1,nz - Z_int(K+1) = Z_int(K) - dZ(i,k) - enddo - - do iM=1,3 - - ! Initialize these for each column-wise calculation - PE = 0.0 - RhoDZ_ML = 0.0 - H_ML = 0.0 - RhoDZ_ML_TST = 0.0 - H_ML_TST = 0.0 - PE_Mixed = 0.0 - - do k=1,nz - - ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) - - ! This is the depth and integral of density - H_ML_TST = H_ML + dZ(i,k) - RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) - - ! The average density assuming all layers including this were mixed - Rho_ML = RhoDZ_ML_TST/H_ML_TST - - ! The PE assuming all layers including this were mixed - ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 - ! but 0 is a good reference value. - PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) - - ! Check if we supplied enough energy to mix to this layer - if (PE_Mixed_TST - PE <= PE_threshold(iM)) then - H_ML = H_ML_TST - RhoDZ_ML = RhoDZ_ML_TST - - else ! If not, we need to solve where the energy ran out - ! This will be done with a Newton's method iteration: - - R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) - D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = Rho_c(i,k) ! The density of this layer - D2 = dZ(i,k) ! The thickness of this layer - - ! This block could be used to calculate the function coefficients if - ! we don't reference all values to a surface designated as z=0 - ! S = Surface - ! Ca = -(R2) - ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) - ! D = D1**2. - 2.*D1*S - ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) - ! Cd = -(R1*D1*D) - ! Ca2 = R2 - ! Cb2 = R2*(2*D1-2*S) - ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 - ! Cc2 = R2*(D+S**2-C) - ! - ! If the surface is S = 0, it simplifies to: - Ca = -R2 - Cb = -(R1 * D1 + R2 * (2. * D1)) - D = D1**2 - Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) - Cd = -R1 * (D1 * D) - Ca2 = R2 - Cb2 = R2 * (2. * D1) - C = D2**2 + D1**2 + 2. * (D1 * D2) - Cc2 = R2 * (D - C) - - ! First guess for an iteration using Newton's method - X = dZ(i,k) * 0.5 - - IT=0 - do while(IT<10)!We can iterate up to 10 times - ! We are trying to solve the function: - ! F(x) = G(x)/H(x)+I(x) - ! for where F(x) = PE+PE_threshold, or equivalently for where - ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 - ! We also need the derivative of this function for the Newton's method iteration - ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) - ! G and its derivative - Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) - Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) - ! H, its inverse, and its derivative - Hx = D1 + X - iHx = 1. / Hx - Hpx = 1. - ! I and its derivative - Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) - Ipx = 0.5 * (2. * Ca2 * X + Cb2) - - ! The Function and its derivative: - PE_Mixed = Gx * iHx + Ix - Fgx = PE_Mixed - (PE + PE_threshold(iM)) - Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx - - ! Check if our solution is within the threshold bounds, if not update - ! using Newton's method. This appears to converge almost always in - ! one step because the function is very close to linear in most applications. - if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then - X2 = X - Fgx / Fpx - IT = IT + 1 - if (X2 < 0. .or. X2 > dZ(i,k)) then - ! The iteration seems to be robust, but we need to do something *if* - ! things go wrong... How should we treat failed iteration? - ! Present solution: Stop trying to compute and just say we can't mix this layer. - X=0 - exit - else - X = X2 - endif - else - exit! Quit the iteration - endif - enddo - H_ML = H_ML + X - exit! Quit looping through the column - endif - enddo - MLD(i,j,iM) = H_ML - enddo - endif ; enddo - enddo - - if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) - if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) - if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) - -end subroutine diagnoseMLDbyEnergy - !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. @@ -2013,13 +1569,6 @@ end subroutine diabatic_aux_end !! The subroutine set_pen_shortwave determines the optical properties of the water column and !! the net shortwave fluxes, and stores them in the optics type, working via calls to set_opacity. !! -!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a -!! density difference criterion, and may also estimate the stratification of the water below -!! this diagnosed mixed layer. -!! -!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy -!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. -!! !! The subroutine applyBoundaryFluxesInOut updates the layer thicknesses, temperatures and !! salinities due to the application of the surface forcing. It may also calculate the implied !! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9386b599a7..6631298690 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -14,7 +14,6 @@ module MOM_diabatic_driver use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave -use MOM_diabatic_aux, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -22,6 +21,7 @@ module MOM_diabatic_driver use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids +use MOM_diagnose_mld, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs From 22c9cbcc37db7e8c9b9a785832bdf40b11b538e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 10 Jul 2024 18:36:08 -0400 Subject: [PATCH 072/128] +Move array_global_min_max to MOM_spatial_means Moved the publicly visible routine array_global_min_max to MOM_spatial_means from MOM_generic_tracer, along with the private supporting function ijk_loc, without any changes to the code itself. This was done because this routine now gives useful debugging information that can be useful outside of the generic tracer module. All answers are bitwise identical, but the module use statements for array_global_min_max will need to be updated. --- src/diagnostics/MOM_spatial_means.F90 | 191 ++++++++++++++++++++++++++ src/tracer/MOM_generic_tracer.F90 | 190 +------------------------ 2 files changed, 193 insertions(+), 188 deletions(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index d8a8abfd99..fe33e38a80 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -7,9 +7,11 @@ module MOM_spatial_means use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real use MOM_coms, only : query_EFP_overflow_error, reset_EFP_overflow_error +use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_error_handler, only : MOM_error, NOTE, WARNING, 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_hor_index, only : hor_index_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -21,6 +23,7 @@ module MOM_spatial_means public :: global_area_integral public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero +public :: array_global_min_max ! 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 @@ -701,4 +704,192 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) end subroutine adjust_area_mean_to_zero + +!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. +!! When there multiple cells with the same extreme values, the reported locations are from the +!! uppermost layer where they occur, and then from the logically northernmost and then eastermost +!! such location on the unrotated version of the grid within that layer. Only ocean points (as +!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points +!! anywhere in the domain, the reported extrema and their locations are all returned as 0. +subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) + integer, intent(in) :: nk !< The number of vertical levels + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for + !! extrema in arbitrary concentration units [CU ~> conc] + real, intent(out) :: g_min !< The global minimum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, intent(out) :: g_max !< The global maximum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of + !! the input tracer array [conc CU-1 ~> 1] + + ! Local variables + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] + integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values + real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and + ! maximum values in units that vary between the array elements [various] + logical :: valid_PE ! True if there are any valid points on the local PE. + logical :: find_location ! If true, report the locations of the extrema + integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE + integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE + integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point + integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin + integer :: i, j, k, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax)) + + ! The initial values set here are never used if there are any valid points. + tmax = -huge(tmax) ; tmin = huge(tmin) + + if (find_location) then + ! Find the maximum and minimum tracer values on this PE and their locations. + valid_PE = .false. + itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + valid_PE = .true. + if (tr_array(i,j,k) > tmax) then + tmax = tr_array(i,j,k) + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_max) then + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc_here + endif + endif + if (tr_array(i,j,k) < tmin) then + tmin = tr_array(i,j,k) + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_min) then + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc_here + endif + endif + endif ; enddo ; enddo ; enddo + else + ! Only the maximum and minimum values are needed, and not their positions. + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) + if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) + endif ; enddo ; enddo ; enddo + endif + + ! Find the global maximum and minimum tracer values. + g_max = tmax ; g_min = tmin + call max_across_PEs(g_max) + call min_across_PEs(g_min) + + if (find_location) then + if (g_max < g_min) then + ! This only occurs if there are no unmasked points anywhere in the domain. + xyz_min_max(:) = 0.0 + else + ! Find the global indices of the maximum and minimum locations. This can + ! occur on multiple PEs. + ijk_min_max(1:2) = 0 + if (valid_PE) then + if (g_min == tmin) ijk_min_max(1) = ijk_loc_min + if (g_max == tmax) ijk_min_max(2) = ijk_loc_max + endif + ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: + ! call max_across_PEs(ijk_min_max, 2) + call max_across_PEs(ijk_min_max(1)) + call max_across_PEs(ijk_min_max(2)) + + ! Set the positions of the extrema if they occur on this PE. This will only + ! occur on a single PE. + xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. + if (valid_PE) then + if (ijk_min_max(1) == ijk_loc_min) then + xyz_min_max(1) = G%geoLonT(itmin,jtmin) + xyz_min_max(2) = G%geoLatT(itmin,jtmin) + xyz_min_max(3) = real(ktmin) + endif + if (ijk_min_max(2) == ijk_loc_max) then + xyz_min_max(4) = G%geoLonT(itmax,jtmax) + xyz_min_max(5) = G%geoLatT(itmax,jtmax) + xyz_min_max(6) = real(ktmax) + endif + endif + + call max_across_PEs(xyz_min_max, 6) + endif + + if (present(xgmin)) xgmin = xyz_min_max(1) + if (present(ygmin)) ygmin = xyz_min_max(2) + if (present(zgmin)) zgmin = xyz_min_max(3) + if (present(xgmax)) xgmax = xyz_min_max(4) + if (present(ygmax)) ygmax = xyz_min_max(5) + if (present(zgmax)) zgmax = xyz_min_max(6) + endif + + if (g_max < g_min) then + ! There are no unmasked points anywhere in the domain. + g_max = 0.0 ; g_min = 0.0 + endif + + if (present(unscale)) then + ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] + g_max = unscale * g_max + g_min = unscale * g_min + endif + +end subroutine array_global_min_max + +! Return a positive integer encoding the rotationally invariant global position of a tracer cell +function ijk_loc(i, j, k, nk, HI) + integer, intent(in) :: i !< Local i-index + integer, intent(in) :: j !< Local j-index + integer, intent(in) :: k !< Local k-index + integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + integer :: ijk_loc ! An integer encoding the cell position in the global grid. + + ! Local variables + integer :: ig, jg ! Global index values with a global computational domain start value of 1. + integer :: ij_loc ! The encoding of the horizontal position + integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone + + ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. + ig = i + HI%idg_offset + (1 - HI%isg) + jg = j + HI%jdg_offset + (1 - HI%jsg) + + ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. + qturns = modulo(HI%turns, 4) + if (qturns == 0) then + ij_loc = ig + HI%niglobal * jg + elseif (qturns == 1) then + ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) + elseif (qturns == 2) then + ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) + elseif (qturns == 3) then + ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig + endif + + ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) + +end function ijk_loc + + end module MOM_spatial_means diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index e998e3029c..6b10d15e2f 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -44,7 +44,7 @@ module MOM_generic_tracer use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments use MOM_open_boundary, only : set_obgc_segments_props use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS - use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP + use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP, array_global_min_max 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 @@ -67,7 +67,7 @@ module MOM_generic_tracer public end_MOM_generic_tracer, MOM_generic_tracer_get public MOM_generic_tracer_stock public MOM_generic_flux_init - public MOM_generic_tracer_min_max, array_global_min_max + public MOM_generic_tracer_min_max public MOM_generic_tracer_fluxes_accumulate public register_MOM_generic_tracer_segments @@ -802,192 +802,6 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, na end function MOM_generic_tracer_min_max -!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. -!! When there multiple cells with the same extreme values, the reported locations are from the -!! uppermost layer where they occur, and then from the logically northernmost and then eastermost -!! such location on the unrotated version of the grid within that layer. Only ocean points (as -!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points -!! anywhere in the domain, the reported extrema and their locations are all returned as 0. - subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & - xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) - integer, intent(in) :: nk !< The number of vertical levels - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for - !! extrema in arbitrary concentration units [CU ~> conc] - real, intent(out) :: g_min !< The global minimum of tr_array, either in - !! the same units as tr_array [CU ~> conc] or in - !! unscaled units if unscale is present [conc] - real, intent(out) :: g_max !< The global maximum of tr_array, either in - !! the same units as tr_array [CU ~> conc] or in - !! unscaled units if unscale is present [conc] - real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the - !! units of G%geoLonT, often [degrees_E] or [km] or [m] - real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the - !! units of G%geoLatT, often [degrees_N] or [km] or [m] - real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] - real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the - !! units of G%geoLonT, often [degrees_E] or [km] or [m] - real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the - !! units of G%geoLatT, often [degrees_N] or [km] or [m] - real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] - real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of - !! the input tracer array [conc CU-1 ~> 1] - - ! Local variables - real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] - integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values - real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and - ! maximum values in units that vary between the array elements [various] - logical :: valid_PE ! True if there are any valid points on the local PE. - logical :: find_location ! If true, report the locations of the extrema - integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE - integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE - integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point - integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - integer :: i, j, k, isc, iec, jsc, jec - - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - - find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & - present(xgmax) .or. present(ygmax) .or. present(zgmax)) - - ! The initial values set here are never used if there are any valid points. - tmax = -huge(tmax) ; tmin = huge(tmin) - - if (find_location) then - ! Find the maximum and minimum tracer values on this PE and their locations. - valid_PE = .false. - itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 - itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 - do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then - valid_PE = .true. - if (tr_array(i,j,k) > tmax) then - tmax = tr_array(i,j,k) - itmax = i ; jtmax = j ; ktmax = k - ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) - elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then - ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) - if (ijk_loc_here > ijk_loc_max) then - itmax = i ; jtmax = j ; ktmax = k - ijk_loc_max = ijk_loc_here - endif - endif - if (tr_array(i,j,k) < tmin) then - tmin = tr_array(i,j,k) - itmin = i ; jtmin = j ; ktmin = k - ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) - elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then - ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) - if (ijk_loc_here > ijk_loc_min) then - itmin = i ; jtmin = j ; ktmin = k - ijk_loc_min = ijk_loc_here - endif - endif - endif ; enddo ; enddo ; enddo - else - ! Only the maximum and minimum values are needed, and not their positions. - do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then - if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) - if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) - endif ; enddo ; enddo ; enddo - endif - - ! Find the global maximum and minimum tracer values. - g_max = tmax ; g_min = tmin - call max_across_PEs(g_max) - call min_across_PEs(g_min) - - if (find_location) then - if (g_max < g_min) then - ! This only occurs if there are no unmasked points anywhere in the domain. - xyz_min_max(:) = 0.0 - else - ! Find the global indices of the maximum and minimum locations. This can - ! occur on multiple PEs. - ijk_min_max(1:2) = 0 - if (valid_PE) then - if (g_min == tmin) ijk_min_max(1) = ijk_loc_min - if (g_max == tmax) ijk_min_max(2) = ijk_loc_max - endif - ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: - ! call max_across_PEs(ijk_min_max, 2) - call max_across_PEs(ijk_min_max(1)) - call max_across_PEs(ijk_min_max(2)) - - ! Set the positions of the extrema if they occur on this PE. This will only - ! occur on a single PE. - xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. - if (valid_PE) then - if (ijk_min_max(1) == ijk_loc_min) then - xyz_min_max(1) = G%geoLonT(itmin,jtmin) - xyz_min_max(2) = G%geoLatT(itmin,jtmin) - xyz_min_max(3) = real(ktmin) - endif - if (ijk_min_max(2) == ijk_loc_max) then - xyz_min_max(4) = G%geoLonT(itmax,jtmax) - xyz_min_max(5) = G%geoLatT(itmax,jtmax) - xyz_min_max(6) = real(ktmax) - endif - endif - - call max_across_PEs(xyz_min_max, 6) - endif - - if (present(xgmin)) xgmin = xyz_min_max(1) - if (present(ygmin)) ygmin = xyz_min_max(2) - if (present(zgmin)) zgmin = xyz_min_max(3) - if (present(xgmax)) xgmax = xyz_min_max(4) - if (present(ygmax)) ygmax = xyz_min_max(5) - if (present(zgmax)) zgmax = xyz_min_max(6) - endif - - if (g_max < g_min) then - ! There are no unmasked points anywhere in the domain. - g_max = 0.0 ; g_min = 0.0 - endif - - if (present(unscale)) then - ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] - g_max = unscale * g_max - g_min = unscale * g_min - endif - - end subroutine array_global_min_max - - ! Return a positive integer encoding the rotationally invariant global position of a tracer cell - function ijk_loc(i, j, k, nk, HI) - integer, intent(in) :: i !< Local i-index - integer, intent(in) :: j !< Local j-index - integer, intent(in) :: k !< Local k-index - integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. - type(hor_index_type), intent(in) :: HI !< Horizontal index ranges - integer :: ijk_loc ! An integer encoding the cell position in the global grid. - - ! Local variables - integer :: ig, jg ! Global index values with a global computational domain start value of 1. - integer :: ij_loc ! The encoding of the horizontal position - integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone - - ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. - ig = i + HI%idg_offset + (1 - HI%isg) - jg = j + HI%jdg_offset + (1 - HI%jsg) - - ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. - qturns = modulo(HI%turns, 4) - if (qturns == 0) then - ij_loc = ig + HI%niglobal * jg - elseif (qturns == 1) then - ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) - elseif (qturns == 2) then - ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) - elseif (qturns == 3) then - ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig - endif - - ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) - - end function ijk_loc - !> This subroutine calculates the surface state and sets coupler values for !! those generic tracers that have flux exchange with atmosphere. !! From 9b45087bdf01e4dd9d8544cdb7404409dd22cda7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 10 Jul 2024 18:36:45 -0400 Subject: [PATCH 073/128] +Add runtime parameter WRITE_TRACER_MIN_MAX Added the new runtime parameters WRITE_TRACER_MIN_MAX and WRITE_TRACER_MIN_MAX_LOC to the MOM_sum_output module to control whether the maximum and minimum values of temperature, salinity and some tracers are periodically written to stdout, perhaps with their locations, as determined by array_global_min_max. These can be expensive global reductions, so by default these are set to false. All solutions are bitwise identical, but there can be some changes to the output to stdout and there will be new entries in the MOM_parameter_doc.debugging files. --- src/diagnostics/MOM_sum_output.F90 | 108 +++++++++++++++++++++++++---- 1 file changed, 94 insertions(+), 14 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index edb66d225c..a97df8e94d 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -20,6 +20,7 @@ module MOM_sum_output use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_spatial_means, only : array_global_min_max use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) @@ -124,6 +125,12 @@ module MOM_sum_output !! interval at which the run is stopped. logical :: write_stocks !< If true, write the integrated tracer amounts !! to stdout when the energy files are written. + logical :: write_min_max !< If true, write the maximum and minimum values of temperature, + !! salinity and some tracer concentrations to stdout when the energy + !! files are written. + logical :: write_min_max_loc !< If true, write the locations of the maximum and minimum values + !! of temperature, salinity and some tracer concentrations to stdout + !! when the energy files are written. integer :: previous_calls = 0 !< The number of times write_energy has been called. integer :: prev_n = 0 !< The value of n from the last call. type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. @@ -179,6 +186,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX", CS%write_min_max, & + "If true, write the maximum and minimum values of temperature, salinity and "//& + "some tracer concentrations to stdout when the energy files are written.", & + default=.false., do_not_log=.not.CS%write_stocks, debuggingParam=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX_LOC", CS%write_min_max_loc, & + "If true, write the locations of the maximum and minimum values of "//& + "temperature, salinity and some tracer concentrations to stdout when the "//& + "energy files are written.", & + default=.false., do_not_log=.not.CS%write_min_max, debuggingParam=.true.) call get_param(param_file, mdl, "DT", CS%dt_in_T, & "The (baroclinic) dynamics time step.", & units="s", scale=US%s_to_T, fail_if_missing=.true.) @@ -404,6 +420,34 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str logical :: date_stamped type(time_type) :: dt_force ! A time_type version of the forcing timestep. + + real :: S_min ! The global minimum unmasked value of the salinity [ppt] + real :: S_max ! The global maximum unmasked value of the salinity [ppt] + real :: S_min_x ! The x-positions of the global salinity minima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_min_y ! The y-positions of the global salinity minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_min_z ! The z-positions of the global salinity minima [layer] + real :: S_max_x ! The x-positions of the global salinity maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_max_y ! The y-positions of the global salinity maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_max_z ! The z-positions of the global salinity maxima [layer] + + real :: T_min ! The global minimum unmasked value of the temperature [degC] + real :: T_max ! The global maximum unmasked value of the temperature [degC] + real :: T_min_x ! The x-positions of the global temperature minima + ! in the units of G%geoLonT, often [degreeT_E] or [km] + real :: T_min_y ! The y-positions of the global temperature minima + ! in the units of G%geoLatT, often [degreeT_N] or [km] + real :: T_min_z ! The z-positions of the global temperature minima [layer] + real :: T_max_x ! The x-positions of the global temperature maxima + ! in the units of G%geoLonT, often [degreeT_E] or [km] + real :: T_max_y ! The y-positions of the global temperature maxima + ! in the units of G%geoLatT, often [degreeT_N] or [km] + real :: T_max_z ! The z-positions of the global temperature maxima [layer] + + ! The units of the tracer stock vary between tracers, with [conc] given explicitly by Tr_units. real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers [kg conc] real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers [conc] @@ -527,11 +571,20 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci nTr_stocks = 0 Tr_minmax_avail(:) = .false. - call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & - stock_units=Tr_units, num_stocks=nTr_stocks,& - got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & - xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& - xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + if (CS%write_min_max .and. CS%write_min_max_loc) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & + xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& + xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + elseif (CS%write_min_max) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max) + else + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks) + endif if (nTr_stocks > 0) then do m=1,nTr_stocks vars(num_nc_fields+m) = var_desc(Tr_names(m), units=Tr_units(m), & @@ -540,6 +593,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci num_nc_fields = num_nc_fields + nTr_stocks endif + if (CS%use_temperature .and. CS%write_stocks) then + call array_global_min_max(tv%T, G, nz, T_min, T_max, & + T_min_x, T_min_y, T_min_z, T_max_x, T_max_y, T_max_z, unscale=US%C_to_degC) + call array_global_min_max(tv%S, G, nz, S_min, S_max, & + S_min_x, S_min_y, S_min_z, S_max_x, S_max_y, S_max_z, unscale=US%S_to_ppt) + endif + if (CS%previous_calls == 0) then CS%mass_prev_EFP = mass_EFP @@ -847,6 +907,15 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Salt*0.001, Salt_chg*0.001, Salt_anom*0.001, Salt_anom/Salt endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Salinity Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_min, S_min_x, S_min_y, S_min_z + write(stdout,'(16X,"Salinity Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_max, S_max_x, S_max_y, S_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Salinity Global Min & Max:",ES24.16,1X,ES24.16)') S_min, S_max + endif + if (Heat == 0.) then write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & Heat, Heat_chg, Heat_anom @@ -854,17 +923,28 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & Heat, Heat_chg, Heat_anom, Heat_anom/Heat endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Temperature Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_min, T_min_x, T_min_y, T_min_z + write(stdout,'(16X,"Temperature Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_max, T_max_x, T_max_y, T_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Temperature Global Min & Max:",ES24.16,1X,ES24.16)') T_min, T_max + endif endif do m=1,nTr_stocks - write(stdout,'(" Total ",a,": ",ES24.16,1X,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,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,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & - Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) + if (CS%write_min_max .and. CS%write_min_max_loc .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_min(m), Tr_min_x(m), Tr_min_y(m), Tr_min_z(m) + write(stdout,'(18X,a," Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_max(m), Tr_max_x(m), Tr_max_y(m), Tr_max_z(m) + elseif (CS%write_min_max .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min & Max:",ES24.16,1X,ES24.16)') & + trim(Tr_names(m)), Tr_min(m), Tr_max(m) endif enddo @@ -1269,9 +1349,9 @@ subroutine write_depth_list(G, US, DL, filename) call create_MOM_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, & extra_axes=extra_axes, global_atts=global_atts) - call MOM_write_field(IO_handle, fields(1), DL%depth, unscale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(2), DL%area, unscale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(3), DL%vol_below, unscale=US%Z_to_m*US%L_to_m**2) + call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) call delete_axis_info(extra_axes) call delete_attribute_info(global_atts) From a78aa57976408fa48cc5a017a6b2e33f41632f65 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 15 Aug 2024 20:20:27 -0800 Subject: [PATCH 074/128] * Fix for spatially varying Bodner fields. - Without this, one can see the tile boundaries in the uhml and vhml fields. --- .../lateral/MOM_mixed_layer_restrat.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index f5deea1f66..b3274475c7 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1064,8 +1064,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr_space(i,j) * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i+1,j))) * grid_dsd ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1105,8 +1105,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( CS%Cr_space(i,j) * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 - * ( ( h_big**2 ) * grd_b ) ) * r_wpup + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i,j+1))) * grid_dsd ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1670,6 +1670,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, filename = trim(inputdir) // "/" // trim(filename) allocate(CS%MLD_Tfilt_space(G%isd:G%ied,G%jsd:G%jed), source=0.0) call MOM_read_data(filename, varname, CS%MLD_Tfilt_space, G%domain, scale=US%s_to_T) + call pass_var(CS%MLD_Tfilt_space, G%domain) endif allocate(CS%Cr_space(G%isd:G%ied,G%jsd:G%jed), source=CS%Cr) if (CS%Cr_grid) then @@ -1681,6 +1682,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, default="Cr") filename = trim(inputdir) // "/" // trim(filename) call MOM_read_data(filename, varname, CS%Cr_space, G%domain) + call pass_var(CS%Cr_space, G%domain) endif call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & From 42c1a3294d567b110f7a8a9efb3f85ecff59114a Mon Sep 17 00:00:00 2001 From: "Alan J. Wallcraft" Date: Mon, 29 Jul 2024 15:43:35 +0000 Subject: [PATCH 075/128] Fix USE_CONT_THICKNESS bug Optionally correct a bug due to a missing halo exchange. This likely isn't needed when compiled for nonsymmetric memory, but the added halo exchange does no harm in such cases. The pass_vector call could probably be replaced with fill_symmetric_edges, except there is no subroutine fill_vector_symmetric_edges_3d. USE_CONT_THICKNESS is not yet widely used, so rather than preserving the old (incorrect) solutions by default, this bug is corrected by default. However, the previous answers can be recovered by setting the new runtime parameter USE_CONT_THICKNESS_BUG to true. This parameter is only used (and logged) when USE_CONT_THICKNESS set to true. By default, this commit does change answers in symmetric memory cases with USE_CONT_THICKNESS = True, and there is a new runtime parameter in such cases. --- .../lateral/MOM_hor_visc.F90 | 32 +++++++++++-------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 94afd0c858..a5f354beba 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -123,6 +123,7 @@ module MOM_hor_visc real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver. + logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points. type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. @@ -282,9 +283,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure type(accel_diag_ptrs), optional, intent(in) :: ADp !< Acceleration diagnostics real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. + optional, intent(inout) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. + optional, intent(inout) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -477,6 +478,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, use_MEKE_Au = allocated(MEKE%Au) use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont) + if (use_cont_huv .and. .not.CS%use_cont_thick_bug) then + call pass_vector(hu_cont, hv_cont, G%domain, To_All+Scalar_Pair, halo=2) + endif rescale_Kh = .false. if (VarMix%use_variable_mixing) then @@ -709,7 +713,14 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! in OBCs, which are not ordinarily be necessary, and might not be necessary ! even with OBCs if the accelerations are zeroed at OBC points, in which ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH - if (CS%use_land_mask) then + if (use_cont_huv) then + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = hu_cont(I,j,k) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = hv_cont(i,J,k) + enddo ; enddo + elseif (CS%use_land_mask) then do j=js-2,je+2 ; do I=is-2,Ieq+1 h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) enddo ; enddo @@ -725,16 +736,6 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif - ! The following should obviously be combined with the previous block if adopted. - if (use_cont_huv) then - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 - h_u(I,j) = hu_cont(I,j,k) - enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 - h_v(i,J) = hv_cont(i,J,k) - enddo ; enddo - endif - ! Adjust contributions to shearing strain and interpolated values of ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments @@ -2140,6 +2141,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & "If true, use thickness at velocity points from continuity solver. This option "//& "currently only works with split mode.", default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS_BUG", CS%use_cont_thick_bug, & + "If true, retain an answer-changing halo update bug when "//& + "USE_CONT_THICKNESS=True. This is not recommended.", & + default=.false., do_not_log=.not.CS%use_cont_thick) + call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) From 2024f6fedceebd38961ab50652a9bc3c28f52a7a Mon Sep 17 00:00:00 2001 From: c2xu <135884058+c2xu@users.noreply.github.com> Date: Wed, 21 Aug 2024 09:38:44 -0300 Subject: [PATCH 076/128] Directional linear wave drag (#703) * Directional linear wave drag This commit allows the linear wave drag to be applied to the u and v components of the barotropic velocity separately. --- src/core/MOM_barotropic.F90 | 54 +++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 14 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bc8fddbdde..eef142702f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -18,7 +18,7 @@ module MOM_barotropic use MOM_grid, only : ocean_grid_type use MOM_harmonic_analysis, only : HA_accum_FtSSH, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher, NORTH_FACE, EAST_FACE 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 @@ -4459,6 +4459,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! drag piston velocity. character(len=80) :: wave_drag_var ! The wave drag piston velocity variable ! name in wave_drag_file. + character(len=80) :: wave_drag_u ! The wave drag piston velocity variable + ! name in wave_drag_file. + character(len=80) :: wave_drag_v ! The wave drag piston velocity variable + ! name in wave_drag_file. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] @@ -4703,8 +4707,17 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & "The name of the variable in BT_WAVE_DRAG_FILE with the "//& - "barotropic linear wave drag piston velocities at h points.", & + "barotropic linear wave drag piston velocities at h points. "//& + "It will not be used if both BT_WAVE_DRAG_U and BT_WAVE_DRAG_V are defined.", & default="rH", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_U", wave_drag_u, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at u points.", & + default="", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_V", wave_drag_v, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at v points.", & + default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & "A scaling factor for the barotropic linear wave drag "//& "piston velocities.", default=1.0, units="nondim", & @@ -4924,19 +4937,32 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file) call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file) - allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + if (len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0) then + call MOM_read_data(wave_drag_file, wave_drag_u, CS%lin_drag_u, G%Domain, & + position=EAST_FACE, scale=GV%m_to_H*US%T_to_s) + call pass_var(CS%lin_drag_u, G%Domain) + CS%lin_drag_u(:,:) = wave_drag_scale * CS%lin_drag_u(:,:) - call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) - call pass_var(lin_drag_h, G%Domain) - do j=js,je ; do I=is-1,ie - CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) - enddo ; enddo - deallocate(lin_drag_h) - endif - endif + call MOM_read_data(wave_drag_file, wave_drag_v, CS%lin_drag_v, G%Domain, & + position=NORTH_FACE, scale=GV%m_to_H*US%T_to_s) + call pass_var(CS%lin_drag_v, G%Domain) + CS%lin_drag_v(:,:) = wave_drag_scale * CS%lin_drag_v(:,:) + + else + allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) + call pass_var(lin_drag_h, G%Domain) + do j=js,je ; do I=is-1,ie + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + enddo ; enddo + deallocate(lin_drag_h) + endif ! len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0 + endif ! len_trim(wave_drag_file) > 0 + endif ! CS%linear_wave_drag CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input From d234bce95b5778ca7e8e4726d137f2b9bedfee06 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin <35234405+Pperezhogin@users.noreply.github.com> Date: Mon, 19 Aug 2024 15:29:01 -0400 Subject: [PATCH 077/128] Restore computation of vorticity in MOM_hor_visc.F90 --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a5f354beba..1d6ff55ea9 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -911,7 +911,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif ! Vorticity - if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0) .or. CS%use_ZB2020) then if (CS%no_slip) then do J=js_vort,je_vort ; do I=is_vort,ie_vort vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) From a6dd0fd0df55c9000b770b9e229d96485812280e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 6 Aug 2024 12:45:05 -0400 Subject: [PATCH 078/128] Makedep output cleanup and PEP8 fixes This patch makes some changes to makedep output: * Compile commands now end with the source code, rather than the include files. This makes it easier to see which file is being compiled. * Blank lines were added inbetween object file rules. * Redundant spaces from absent include flags is now removed. Also some minor PEP8-like cleanups: * Some (but not all) 79+ character lines were reduced or split. * Some (but not all) single-letter variables were renamed. * A bad error handler for missing macros was fixed. Nothing particularly major here, but build output should be more readable. --- ac/makedep | 114 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 69 insertions(+), 45 deletions(-) diff --git a/ac/makedep b/ac/makedep index e0d350857e..3ae3567d20 100755 --- a/ac/makedep +++ b/ac/makedep @@ -214,68 +214,91 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # Create new makefile with open(makefile, 'w') as file: print("# %s created by makedep" % (makefile), file=file) - print("", file=file) + print(file=file) print("# Invoked as", file=file) print('# '+' '.join(sys.argv), file=file) - print("", file=file) + print(file=file) print("all:", " ".join(targets), file=file) - print("", file=file) + # print(file=file) # print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) # print("# record it here from when makedep was previously invoked.", file=file) # print("SRC_DIRS ?= ${SRC_DIRS}", file=file) - # print("", file=file) + # print(file=file) # print("# all_files:", ' '.join(all_files), file=file) - # print("", file=file) # Write rule for each object from Fortran - for o in sorted(o2F90.keys()): - found_mods = [m for m in o2uses[o] if m in all_modules] - found_objs = [mod2o[m] for m in o2uses[o] if m in all_modules] + for obj in sorted(o2F90.keys()): + found_mods = [m for m in o2uses[obj] if m in all_modules] + found_objs = [mod2o[m] for m in o2uses[obj] if m in all_modules] found_deps = [ dep for pair in zip(found_mods, found_objs) for dep in pair ] - missing_mods = [m for m in o2uses[o] if m not in all_modules] + missing_mods = [m for m in o2uses[obj] if m not in all_modules] - incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F, defines) - inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] + incs, inc_used = nested_inc(o2h[obj] + o2inc[obj], f2F, defines) + inc_mods = [ + u for u in inc_used if u not in found_mods and u in all_modules + ] incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) - incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) if debug: - print("# Source file {} produces:".format(o2F90[o]), file=file) - print("# object:", o, file=file) - print("# modules:", ' '.join(o2mods[o]), file=file) - print("# uses:", ' '.join(o2uses[o]), file=file) + print("# Source file {} produces:".format(o2F90[obj]), file=file) + print("# object:", obj, file=file) + print("# modules:", ' '.join(o2mods[obj]), file=file) + print("# uses:", ' '.join(o2uses[obj]), file=file) print("# found mods:", ' '.join(found_mods), file=file) print("# found objs:", ' '.join(found_objs), file=file) print("# missing:", ' '.join(missing_mods), file=file) print("# includes_all:", ' '.join(incs), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) print("# incargs:", ' '.join(incargs), file=file) - print("# program:", ' '.join(o2prg[o]), file=file) - if o2mods[o]: - print(' '.join(o2mods[o])+':', o, file=file) - print(o + ':', o2F90[o], ' '.join(inc_mods + incdeps + found_deps), file=file) - print('\t'+fc_rule, ' '.join(incargs), file=file) + print("# program:", ' '.join(o2prg[obj]), file=file) + + # Fortran Module dependencies + if o2mods[obj]: + print(' '.join(o2mods[obj]) + ':', obj, file=file) + + # Fortran object dependencies + obj_incs = ' '.join(inc_mods + incdeps + found_deps) + print(obj + ':', o2F90[obj], obj_incs, file=file) + + # Fortran object build rule + obj_rule = ' '.join([fc_rule] + incargs + ['-c', '$<']) + print('\t' + obj_rule, file=file) # Write rule for each object from C - for o in sorted(o2c.keys()): - incdeps = sorted(set([f2F[h] for h in o2h[o] if h in f2F])) - incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + for obj in sorted(o2c.keys()): + incdeps = sorted(set([f2F[h] for h in o2h[obj] if h in f2F])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) if debug: - print("# Source file %s produces:" % (o2c[o]), file=file) - print("# object:", o, file=file) - print("# includes_all:", ' '.join(o2h[o]), file=file) + print("# Source file %s produces:" % (o2c[obj]), file=file) + print("# object:", obj, file=file) + print("# includes_all:", ' '.join(o2h[obj]), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) print("# incargs:", ' '.join(incargs), file=file) - print(o+':', o2c[o], ' '.join(incdeps), file=file) - print('\t$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS) -c $<', ' '.join(incargs), file=file) + + # C object dependencies + print(obj + ':', o2c[obj], ' '.join(incdeps), file=file) + + # C object build rule + c_rule = ' '.join( + ['$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS)'] + incargs + ['-c', '$<'] + ) + #print('\t' + c_rule, ' '.join(incargs), '-c', '$<', file=file) + print('\t' + c_rule, file=file) # Externals (so called) if link_externals: - print("", file=file) + print(file=file) print("# Note: The following object files are not associated with " "modules so we assume we should link with them:", file=file) print("# ", ' '.join(externals), file=file) @@ -286,23 +309,23 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # Write rules for linking executables for p in sorted(prg2o.keys()): o = prg2o[p] - print("", file=file) + print(file=file) print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) # Write rules for building libraries for lb in sorted(targ_libs): - print("", file=file) + print(file=file) print(lb+':', ' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) print('\t$(AR) $(ARFLAGS) $@ $^', file=file) # Write cleanup rules - print("", file=file) + print(file=file) print("clean:", file=file) print('\trm -f *.mod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) # Write re-generation rules - print("", file=file) + print(file=file) print("remakedep:", file=file) print('\t'+' '.join(sys.argv), file=file) @@ -366,7 +389,6 @@ def scan_fortran_file(src_file, defines=None): cpp_defines = defines if defines is not None else [] - #cpp_macros = [define.split('=')[0] for define in cpp_defines] cpp_macros = dict([t.split('=') for t in cpp_defines]) cpp_group_stack = [] @@ -374,16 +396,16 @@ def scan_fortran_file(src_file, defines=None): lines = file.readlines() external_namespace = True - # True if we are in the external (i.e. global) namespace + # True if we are in the external (i.e. global) namespace file_has_externals = False - # True if the file contains any external objects + # True if the file contains any external objects cpp_exclude = False - # True if the parser excludes the subsequent lines + # True if the parser excludes the subsequent lines cpp_group_stack = [] - # Stack of condition group exclusion states + # Stack of condition group exclusion states for line in lines: # Start of #ifdef condition group @@ -446,14 +468,16 @@ def scan_fortran_file(src_file, defines=None): if match: new_macro = line.lstrip()[1:].split()[1] try: - cpp_macros.remove(new_macro) - except: - # Ignore missing macros (for now?) + cpp_macros.pop(new_macro) + except KeyError: + # C99: "[A macro] is ignored if the specified identifier is + # not currently defined as a macro name." continue match = re_module.match(line.lower()) if match: - if match.group(1) not in 'procedure': # avoid "module procedure" statements + # Avoid "module procedure" statements + if match.group(1) not in 'procedure': module_decl.append(match.group(1)) external_namespace = False @@ -632,9 +656,9 @@ parser.add_argument( ) parser.add_argument( '-f', '--fc_rule', - default="$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<", + default="$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)", help="String to use in the compilation rule. Default is: " - "'$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<'" + "'$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)'" ) parser.add_argument( '-x', '--exec_target', From 91eee521db76ff451d3b703c27a0d74eb1ab718b Mon Sep 17 00:00:00 2001 From: William Xu Date: Thu, 5 Sep 2024 21:09:29 -0300 Subject: [PATCH 079/128] Inline harmonic analysis Set default HAready = False Also made additional adjustment to ensure harmonic analysis is not activated if tide is not used in the model. --- src/core/MOM_barotropic.F90 | 4 +--- src/core/MOM_dynamics_split_RK2.F90 | 2 +- src/core/MOM_dynamics_split_RK2b.F90 | 2 +- src/diagnostics/MOM_harmonic_analysis.F90 | 4 +++- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index dd140a9fd4..e97e794cd6 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4504,9 +4504,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (present(SAL_CSp)) then CS%SAL_CSp => SAL_CSp endif - if (present(HA_CSp)) then - CS%HA_CSp => HA_CSp - endif ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "SPLIT", CS%split, default=.true., do_not_log=.true.) @@ -4639,6 +4636,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, default=.not.visc_rem_bug) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=use_tides) det_de = 0.0 diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 11c3ff1873..addfb0e212 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1547,7 +1547,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & - CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp, CS%HA_CSp) + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp, HA_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 0220db7993..9227ea57ed 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -1463,7 +1463,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%SAL_CSp, CS%HA_CSp) + CS%SAL_CSp, HA_CSp) flux_units = get_flux_units(GV) thickness_units = get_thickness_units(GV) diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 index 76adad5c8e..1e3b9895cb 100644 --- a/src/diagnostics/MOM_harmonic_analysis.F90 +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -39,7 +39,7 @@ module MOM_harmonic_analysis !> The public control structure of the MOM_harmonic_analysis module type, public :: harmonic_analysis_CS ; private - logical :: HAready = .true. !< If true, perform harmonic analysis + logical :: HAready = .false. !< If true, perform harmonic analysis type(time_type) :: & time_start, & !< Start time of harmonic analysis time_end, & !< End time of harmonic analysis @@ -107,6 +107,8 @@ subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, CS%HAready = .false. ; return endif + CS%HAready = .true. + if (HA_start_time < 0.0) then HA_start_time = HA_end_time + HA_start_time if (HA_start_time <= 0.0) HA_start_time = 0.0 From 2316ae56e1c030bcf638a89309f2bf94c939c525 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Mon, 9 Sep 2024 12:05:20 -0400 Subject: [PATCH 080/128] diffusivities from internal tides ray tracing algo (#677) * (*)bugfixes for internal tides - TKE_itidal_input values are set to zero where it is not applied to the model so that diagnostics are consistent - removed useless halo updates - diagnose energy loss terms as dE/dt instead of equivalent loss rate to properly close energy budget - tot_vel_btTide2 was already a velocity squared, no need to square again - Froude loss term was not properly initialized - add missing halo updates for internal tide speed - compute residual/critical slopes loss only where it has a meaning, allows to clean up noise in field - uh/vh in energy flux routines do not need to be inout * Refactor debugging internal tides - put test for negative energt behind debug flag - do energy budget in debug mode - add flags to skip refraction, propagation for debugging - add option to input TKE only at first step for debugging - add checksums for unit scaling testing - rewrite terms in refraction to avoid substractions of velocities - rewrite gradient of coriolis in rotationally invariant form * Add internal tides diffusivities - MOM_internal_tides gets new routine that converts TKE losses into diffusivities using the TKE_to_Kd array - MOM_set_diffusivities handles the diagnostics * extend find_rho_bottom to get bbl thickness/index * new calculation of BBL, profiles in H units --- src/core/MOM.F90 | 2 +- src/core/MOM_interface_heights.F90 | 60 +- .../lateral/MOM_internal_tides.F90 | 1738 +++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 5 +- .../vertical/MOM_internal_tide_input.F90 | 59 +- .../vertical/MOM_set_diffusivity.F90 | 201 +- 6 files changed, 1604 insertions(+), 461 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8d45114a39..2f5ac6e489 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2890,7 +2890,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (.not. CS%adiabatic) then - call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + call register_diabatic_restarts(G, GV, US, param_file, CS%int_tide_CSp, restart_CSp) endif call callTree_waypoint("restart registration complete (initialize_MOM)") diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 6e272f7b41..c594aed206 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -394,10 +394,12 @@ end subroutine find_col_avg_SpV !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. -subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) +subroutine find_rho_bottom(G, GV, US, tv, h, dz, pres_int, dz_avg, j, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(GV)), & @@ -405,10 +407,10 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available - !! thermodynamic fields. integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index ! Local variables real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] @@ -441,6 +443,53 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie rho_bot(i) = GV%Rho0 enddo + + ! Obtain bottom boundary layer thickness and index of top layer + do i=is,ie + hb(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer + else + frac_in = 0.0 + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + h_bbl_frac(i) = 0.0 + endif ; enddo + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + h_bot(i) = hb(i) + h_bbl_frac(i) + enddo + else ! Check that SpV_avg has been set. if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & @@ -450,7 +499,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) ! specified distance, with care taken to avoid having compressibility lead to an imprint ! of the layer thicknesses on this density. do i=is,ie - hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) do_i(i) = .true. if (G%mask2dT(i,j) <= 0.0) then @@ -470,10 +519,12 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k do_any = .true. else if (dz(i,k) > 0.0) then frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer else frac_in = 0.0 endif @@ -516,6 +567,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + h_bot(i) = hb(i) + h_bbl_frac(i) enddo endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index e6981496bc..819e77b2c2 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -5,27 +5,29 @@ module MOM_internal_tides ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group -use MOM_domains, only : AGRID, To_South, To_West, To_All -use MOM_domains, only : create_group_pass, do_group_pass, pass_var +use MOM_domains, only : AGRID, To_South, To_West, To_All, CGRID_NE +use MOM_domains, only : create_group_pass, pass_var, pass_vector use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass 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_forcing_type,only : forcing use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info -use MOM_io, only : set_axis_info, get_axis_info +use MOM_io, only : set_axis_info, get_axis_info, stdout use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init @@ -35,7 +37,7 @@ module MOM_internal_tides public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end -public get_lowmode_loss +public get_lowmode_loss, get_lowmode_diffusivity !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private @@ -55,6 +57,13 @@ module MOM_internal_tides !! areas when estimating CFL numbers. Without aggress_adjust, !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics + logical :: apply_refraction !< If false, skip refraction (for debugging) + logical :: apply_propagation !< If False, do not propagate energy (for debugging) + logical :: debug !< If true, use debugging prints + logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging) + logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement) + logical :: add_tke_forcing = .true. !< Whether to add forcing, used by init_forcing_only real, allocatable, dimension(:,:) :: fraction_tidal_input !< how the energy from one tidal component is distributed @@ -80,32 +89,48 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] + !< energy lost due to misc background processes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] + !< energy lost due to quadratic bottom drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] + !< energy lost due to wave breaking [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here; !! This will be multiplied by N and the squared near-bottom velocity (and by !! the near-bottom density in non-Boussinesq mode) to get the energy losses !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + !< energy lost due to small-scale wave drag [H Z2 T-3 ~> m3 s-3 or 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] + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_slope_loss + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:) :: TKE_input_glo_dt + !< The energy input to the internal waves * dt [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, allocatable, dimension(:,:) :: TKE_leak_loss_glo_dt + !< energy lost due to misc background processes * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_quad_loss_glo_dt + !< energy lost due to quadratic bottom drag * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_Froude_loss_glo_dt + !< energy lost due to wave breaking [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_itidal_loss_glo_dt + !< energy lost due to small-scale wave drag [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_residual_loss_glo_dt + !< internal tide energy loss due to the residual at slopes [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: error_mode + !< internal tide energy budget error for each mode [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or 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] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or 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] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or 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] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) !! for each frequency and each mode [nondim] real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and @@ -121,7 +146,9 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [H Z2 T-2 L2 ~> m5 s-2 or J] + real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] + integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] 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 @@ -130,6 +157,10 @@ module MOM_internal_tides real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] + real :: gamma_osborn !< Mixing efficiency from Osborn 1980 [nondim] + real :: Kd_min !< The minimum diapycnal diffusivity. [L2 T-1 ~> m2 s-1] + real :: max_TKE_to_Kd !< Maximum allowed value for TKE_to_kd [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: min_thick_layer_Kd !< minimum layer thickness allowed to use with TKE_to_kd [H ~> m] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -138,30 +169,40 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. - real :: En_check_tol !< An energy density tolerance for flagging points with an imbalance in the - !! internal tide energy budget when apply_Froude_drag is True [R Z3 T-2 ~> J m-2] + real :: En_check_tol !< An energy density tolerance for flagging points with small negative + !! internal tide energy [H Z2 T-2 ~> m3 s-2 or J m-2] 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] + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_ini_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the start of the routine (for diags) + real, allocatable :: En_end_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the end of the routine (for diags) real, allocatable :: En_restart_mode1(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 1 [R Z3 T-2 ~> J m-2] + !! for mode 1 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode2(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 2 [R Z3 T-2 ~> J m-2] + !! for mode 2 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode3(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 3 [R Z3 T-2 ~> J m-2] + !! for mode 3 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode4(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 4 [R Z3 T-2 ~> J m-2] + !! for mode 4 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode5(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 5 [R Z3 T-2 ~> J m-2] + !! for mode 5 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + real :: Int_tide_decay_scale !< vertical decay scale for St Laurent profile [Z ~> m] + real :: Int_tide_decay_scale_slope !< vertical decay scale for St Laurent profile on slopes [Z ~> m] type(wave_speed_CS) :: wave_speed !< Wave speed control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the @@ -236,7 +277,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Local variables real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & - TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The energy input to the internal waves [H Z2 T-3 ~> m3 s-3 or W m-2]. vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),2) :: & @@ -244,30 +285,32 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & - tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] + tot_En_mode, & ! energy summed over angles only [H Z2 T-2 ~> m3 s-2 or J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - tot_vel_btTide2, & - tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] + tot_vel_btTide2, & ! [L2 T-2 ~> m2 s-2] + tot_En, & ! energy summed over angles, modes, frequencies [H Z2 T-2 ~> m3 s-2 or J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & - ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + ! energy loss rates summed over angle, freq, and mode [H Z2 T-3 ~> m3 s-3 or W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] leak_loss_mode, & quad_loss_mode, & Froude_loss_mode, & residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over - ! all angles) [R Z3 T-3 ~> W m-2] - + ! all angles) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: En_restart_factor ! A multiplicative factor of the form 2**En_restart_power [nondim] + real :: I_En_restart_factor ! The inverse of the restart mult factor [nondim] real :: freq2 ! The frequency squared [T-2 ~> s-2] real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] @@ -277,10 +320,20 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] - real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - 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] + real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_new, En_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_sumtmp ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_initial, Delta_E_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks + ! [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks + ! [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal + ! [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! [m3 s-2 or J m-2 ~> H Z2 T-2] character(len=160) :: mesg ! The text of an error message integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle @@ -292,8 +345,17 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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 + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + cn_subRO = 1e-30*US%m_s_to_L_T - en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T + en_subRO = 1e-30*J_m2_to_HZ2_T2 + + I_dt = 1.0 / dt + En_restart_factor = 2**CS%En_restart_power + I_En_restart_factor = 1.0 / En_restart_factor ! initialize local arrays TKE_itidal_input(:,:,:) = 0. @@ -307,33 +369,44 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rebuild energy density array from multiple restarts do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + ! save initial energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_ini_glo(fr,m) = En_sumtmp + enddo ; enddo + endif + ! Set properties related to the internal tides, such as the wave speeds, storing some ! of them in the control structure for this module. if (CS%uniform_test_cg > 0.0) then @@ -347,6 +420,19 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! It can be 1 point smaller if teleport is not used. endif + call pass_var(cn,G%Domain) + + if (CS%debug) then + call hchksum(cn(:,:,1), "CN mode 1", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + call hchksum(CS%w_struct(:,:,:,1), "Wstruct mode 1", G%HI, haloshift=0) + call hchksum(CS%u_struct(:,:,:,1), "Ustruct mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_bot(:,:,1), "Ustruct_bot mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_max(:,:,1), "Ustruct_max mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%int_w2(:,:,1), "int_w2", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(CS%int_U2(:,:,1), "int_U2", G%HI, haloshift=0, scale=GV%H_to_mks*US%m_to_Z**2) + call hchksum(CS%int_N2w2(:,:,1), "int_N2w2", G%HI, haloshift=0, scale=GV%H_to_mks*US%s_to_T**2) + endif + ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. ! Uncomment if wave_speed is not used to calculate the true values (BDM). @@ -356,62 +442,116 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Add the forcing.*************************************************************** - call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%add_tke_forcing) then - if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle) - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo ; enddo - elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 - a = CS%energized_angle - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo - else - call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& - "band that does not exist.") + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + + if (CS%debug) then + call hchksum(TKE_itidal_input(:,:,1), "TKE_itidal_input", G%HI, haloshift=0, & + scale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**3) + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides bf input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + endif + + if (CS%energized_angle <= 0) then + frac_per_sector = 1.0 / real(CS%nAngle) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo ; enddo + elseif (CS%energized_angle <= CS%nAngle) then + frac_per_sector = 1.0 + a = CS%energized_angle + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo + else + call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& + "band that does not exist.") + endif + endif ! add tke forcing + + if (CS%init_forcing_only) CS%add_tke_forcing=.false. + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save forcing for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(dt*frac_per_sector*(1.0-CS%q_itides)* & + CS%fraction_tidal_input(fr,m)*TKE_itidal_input(:,:,fr), & + G, scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_input_glo_dt(fr,m) = En_sumtmp + enddo ; enddo endif ! Pass a test vector to check for grid rotation in the halo updates. do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo - do m=1,CS%nMode ; do fr=1,CS%nFreq - call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after forcing') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after forcing', CS%En_sum + enddo ; enddo + endif + ! Apply half the refraction. - do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%nAngle, CS%use_PPMang) - enddo ; enddo + if (CS%apply_refraction) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%nAngle, CS%use_PPMang) + enddo ; enddo + endif ! A this point, CS%En is only valid on the computational domain. - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif - enddo ; enddo - enddo ; enddo ; enddo + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - call do_group_pass(pass_En, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 1/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif call complete_group_pass(pass_test, G%domain) @@ -423,52 +563,98 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rotate points in the halos as necessary. call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after correct halo rotation', CS%En_sum + enddo ; enddo + endif + ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. + CS%TKE_slope_loss(:,:,:,fr,m) = 0. - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) + if (CS%apply_propagation) then + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & + G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) + endif enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large - write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 endif - CS%En(i,j,a,fr,m) = 0.0 - endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after propagate', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - ! Apply the other half of the refraction. - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%NAngle, CS%use_PPMang) - enddo ; enddo - ! A this point, CS%En is only valid on the computational domain. + if (CS%apply_refraction) then + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%NAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 2/2 refraction', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & @@ -487,25 +673,55 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale - ! to each En component (technically not correct; fix later) - CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + En_b = CS%En(i,j,a,fr,m) ! save previous value + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * CS%decay_rate)) ! implicit update + CS%TKE_leak_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! compute exact loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] + CS%En(i,j,a,fr,m) = En_a ! update value enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after background drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_leak_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after background drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_leak_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_leak_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then @@ -514,7 +730,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + (vel_btTide(i,j,fr)**2) enddo ; enddo ; enddo do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied @@ -524,38 +740,66 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) * GV%Z_to_H*I_D_here enddo ; enddo ; enddo ; enddo else do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + I_mass = GV%RZ_to_H * I_D_here drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * I_mass)) + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) enddo ; enddo ; enddo ; enddo endif + + if (CS%debug) call hchksum(drag_scale(:,:,1,1), "dragscale", G%HI, haloshift=0, scale=US%s_to_T) + if (CS%debug) call hchksum(tot_vel_btTide2(:,:), "tot_vel_btTide2", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * drag_scale(i,j,fr,m))) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after quad", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_quad_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_quad_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to scattering (wave-drag)-------------------- ! still need to allow a portion of the extracted energy to go to higher modes. @@ -572,18 +816,18 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) ! Back-calculate amplitude from energy equation if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%H_to_RZ*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + KE_term = 0.25*GV%H_to_RZ*( (((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m)) + & CS%int_w2(i,j,m) ) PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) if (KE_term + PE_term > 0.0) then - W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + W0 = sqrt( GV%H_to_RZ * tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) else !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") W0 = 0.0 @@ -608,19 +852,45 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, halo_size=0) endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: before Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: before Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_itidal_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_itidal_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then @@ -632,85 +902,131 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Calculate horizontal phase velocity magnitudes f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) c_phase = 0.0 + CS%TKE_Froude_loss(i,j,:,fr,m) = 0. ! init for all angles if (Kmag2 > 0.0) then c_phase = sqrt(freq2/Kmag2) Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then - En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step - loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) + !loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) - CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) - ! Update energy - En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging - ! Re-scale (reduce) energy due to breaking - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max - ! Check (for debugging only) - if (abs(En_new - En_check) > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & - all_print=.true.) - write(mesg,*) "En_new=", En_new , "En_check=", En_check - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif + !CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m)/Fr2_max + CS%TKE_Froude_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo - ! Check (for debugging) - Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt - TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) - if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot)*dt > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & - all_print=.true.) - write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & - "TKE_Froude_loss_tot=", TKE_Froude_loss_tot - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif endif ! Fr2>1 endif ! Kmag2>0 CS%cp(i,j,fr,m) = c_phase enddo ; enddo enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after Froude drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_Froude_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_Froude_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_Froude_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! 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=js,je ; do i=is,ie - ! implicit form + ! implicit form is rewritten to minimize number of divisions !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)) + ! only compute when partial reflection is present not to create noise elsewhere + if (CS%refl_pref_logical(i,j)) then + En_b = CS%En(i,j,a,fr,m) + En_a = (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_slope_loss(i,j,a,fr,m))) + CS%TKE_residual_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a + endif + enddo ; enddo ; enddo ; enddo ; enddo - ! 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) + else + ! zero out the residual loss term so it does not count towards diagnostics + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + CS%TKE_residual_loss(i,j,a,fr,m) = 0. enddo ; enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after slope", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') + enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_residual_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_residual_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif - ! Check for energy conservation on computational domain.************************* - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') - enddo ; enddo + !---- energy budget ---- + if (CS%debug) then + ! save final energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_end_glo(fr,m) = En_sumtmp + enddo ; enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + CS%error_mode(fr,m) = CS%En_ini_glo(fr,m) + CS%TKE_input_glo_dt(fr,m) - CS%TKE_leak_loss_glo_dt(fr,m) - & + CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & + CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & + CS%En_end_glo(fr,m) + if (is_root_pe()) write(stdout,'(A,F18.10)'), "error in Energy budget", CS%error_mode(fr,m) + enddo ; enddo + endif ! Output diagnostics.************************************************************ avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -743,30 +1059,30 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! split energy array into multiple restarts do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) * En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) * En_restart_factor enddo ; enddo ; enddo ; enddo endif @@ -889,12 +1205,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, US, CS, En, label) +subroutine sum_En(G, GV, US, CS, En, label) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type),intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & - intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. + intent(in) :: En !< The energy density of the internal tides [H Z2 T-2 ~> m3 s-2 or J m-2]. 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] @@ -906,7 +1223,7 @@ subroutine sum_En(G, US, CS, En, label) En_sum = 0.0 do a=1,CS%nAngle - En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=US%RZ3_T3_to_W_m2*US%T_to_s) + En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**2) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -945,32 +1262,49 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. + intent(inout) :: En !< Energy density of the internal waves [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] + intent(out) :: TKE_loss !< Energy loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables integer :: j, i, m, fr, a, is, ie, js, je, halo - real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] - real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] + real :: En_tot ! energy for a given mode, frequency + ! and point summed over angles [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency + ! and point summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! fraction of energy in each wedge [nondim] real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) [nondim] real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] - real :: En_negl ! negligibly small number to prevent division by zero [R Z3 T-2 ~> J m-2] + real :: En_negl ! negligibly small number to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! energy before and after timestep [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + J_m2_to_HZ2_T2 = GV%m_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + HZ2_T3_to_W_m2 = GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3) + + I_dt = 1.0 / dt q_itides = CS%q_itides - En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 + En_negl = 1e-30*J_m2_to_HZ2_T2 if (present(halo_size)) then halo = halo_size is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo endif + if (CS%debug) then + call hchksum(TKE_loss_fixed, "TKE loss fixed", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2*(US%Z_to_m**3)*GV%m_to_H*(US%m_to_L**2)) + call hchksum(Nb(:,:), "Nbottom", G%HI, haloshift=0, scale=US%s_to_T) + call hchksum(Ub(:,:,1,1), "Ubottom", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + endif + do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq ! Sum energy across angles @@ -979,11 +1313,11 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe En_tot = En_tot + En(i,j,a,fr,m) enddo - ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. + ! Calculate TKE loss rate; units of [H Z2 T-3 ~> m3 s-3 or W m-2] here. if (GV%Boussinesq .or. GV%semi_Boussinesq) then - TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * GV%RZ_to_H*GV%Z_to_H*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 else - TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * (GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 endif ! Update energy remaining (this is a pseudo implicit calc) @@ -991,9 +1325,12 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + En_b = En(i,j,a,fr,m) + En_a = En(i,j,a,fr,m) / (1.0 + (dt*loss_rate)) + TKE_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! overwrite with exact value + En(i,j,a,fr,m) = En_a enddo else ! no loss if no energy @@ -1002,24 +1339,6 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe enddo endif - ! Update energy remaining (this is the old explicit calc) - !if (En_tot > 0.0) then - ! do a=1,CS%nAngle - ! frac_per_sector = En(i,j,a,fr,m)/En_tot - ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt - ! else - ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than available, "// & - ! " setting En to zero.", all_print=.true.) - ! En(i,j,a,fr,m) = 0.0 - ! endif - ! enddo - !else - ! ! no loss if no energy - ! TKE_loss(i,j,:,fr,m) = 0.0 - !endif - enddo ; enddo ; enddo ; enddo end subroutine itidal_lowmode_loss @@ -1035,15 +1354,451 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) type(int_tide_CS), intent(in) :: CS !< Internal tide control structure character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism [R Z3 T-3 ~> W m-2]. + !! mechanism [H Z2 T-3 ~> m3 s-3 or W m-2]. - if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) + if (mechanism == 'SlopeDrag') TKE_loss_sum = CS%tot_residual_loss(i,j) end subroutine get_lowmode_loss + +!> Returns the values of diffusivity corresponding to various mechanisms +subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, Kd_max, CS, & + Kd_leak, Kd_quad, Kd_itidal, Kd_Froude, Kd_slope, & + Kd_lay, Kd_int, profile_leak, profile_quad, profile_itidal, & + profile_Froude, profile_slope) + + 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] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: k_bot !< Bottom boundary layer top layer index + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency of the + !! interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + !! Set this to a negative value to have no limit. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(int_tide_cs), intent(in) :: CS !< The control structure for this module + + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_leak !< Diffusivity due to background drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_quad !< Diffusivity due to bottom drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_itidal !< Diffusivity due to wave drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_Froude !< Diffusivity due to high Froude breaking + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_slope !< Diffusivity due to critical slopes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_leak !< Normalized profile for background drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_quad !< Normalized profile for bottom drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_itidal !< Normalized profile for wave drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_Froude !< Normalized profile for Froude drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_slope !< Normalized profile for critical slopes + !! [H-1 ~> m-1] + + ! local variables + real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> W/m2] + real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1] + real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2] + real :: tmp_StLau ! tmp var for renormalization for StLaurent profile [nondim] + real :: tmp_StLau_slope ! tmp var for renormalization for StLaurent profile [nondim] + real :: renorm_StLau ! renormalization for StLaurent profile [nondim] + real :: renorm_StLau_slope! renormalization for StLaurent profile [nondim] + real :: htot ! total depth of water column [H ~> m] + real :: htmp ! local value of thickness in layers [H ~> m] + real :: h_d ! expomential decay length scale [H ~> m] + real :: h_s ! expomential decay length scale on the slope [H ~> m] + real :: I_h_d ! inverse of expomential decay length scale [H-1 ~> m-1] + real :: I_h_s ! inverse of expomential decay length scale on the slope [H-1 ~> m-1] + real :: TKE_to_Kd_lim ! limited version of TKE_to_Kd [T2 Z-1 ~> s2 m-1] + + ! vertical profiles have units Z-1 for conversion to Kd to be dim correct (see eq 2 of St Laurent GRL 2002) + real, dimension(SZK_(GV)) :: profile_N ! vertical profile varying with N [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_N2 ! vertical profile varying with N2 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent_slope ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_BBL ! vertical profile Heavyside BBL [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: Kd_leak_lay ! Diffusivity due to background drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_quad_lay ! Diffusivity due to bottom drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_itidal_lay ! Diffusivity due to wave drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_Froude_lay ! Diffusivity due to high Froude breaking [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_slope_lay ! Diffusivity due to critical slopes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: hmin ! A minimum allowable thickness [H ~> m] + real :: h_rmn ! Remaining thickness in k-loop [H ~> m] + real :: frac ! A fraction of thicknesses [nondim] + real :: verif_N, & ! profile verification [nondim] + verif_N2, & ! profile verification [nondim] + verif_bbl, & ! profile verification [nondim] + verif_stl1,& ! profile verification [nondim] + verif_stl2,& ! profile verification [nondim] + threshold_renorm_N2,& ! Maximum allowable error on N2 profile [H T-2 ~> m.s-2] + threshold_renorm_N, & ! Maximum allowable error on N profile [H T-1 ~> m.s-1] + threshold_verif ! Maximum allowable error on verification [nondim] + + logical :: non_Bous ! fully Non-Boussinesq + integer :: i, k, is, ie, nz + + is=G%isc ; ie=G%iec ; nz=GV%ke + + non_Bous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + + h_d = CS%Int_tide_decay_scale + h_s = CS%Int_tide_decay_scale_slope + I_h_d = 1 / h_d + I_h_s = 1 / h_s + + hmin = 1.0e-6*GV%m_to_H + threshold_renorm_N2 = 1.0e-13 * GV%m_to_H * US%T_to_s**2 + threshold_renorm_N = 1.0e-13 * GV%m_to_H * US%T_to_s + threshold_verif = 1.0e-13 + + ! init output arrays + profile_leak(:,:) = 0.0 + profile_quad(:,:) = 0.0 + profile_slope(:,:) = 0.0 + profile_itidal(:,:) = 0.0 + profile_Froude(:,:) = 0.0 + + Kd_leak_lay(:) = 0.0 + Kd_quad_lay(:) = 0.0 + Kd_itidal_lay(:) = 0.0 + Kd_Froude_lay(:) = 0.0 + Kd_slope_lay(:) = 0.0 + + Kd_leak(:,:) = 0.0 + Kd_quad(:,:) = 0.0 + Kd_itidal(:,:) = 0.0 + Kd_Froude(:,:) = 0.0 + Kd_slope(:,:) = 0.0 + + do i=is,ie + + ! create vertical profiles for diffusivites in layers + renorm_N = 0.0 + renorm_N2 = 0.0 + renorm_StLau = 0.0 + renorm_StLau_slope = 0.0 + tmp_StLau = 0.0 + tmp_StLau_slope = 0.0 + htot = 0.0 + htmp = 0.0 + + do k=1,nz + ! N-profile + if (N2_lay(i,k) < 0.) call MOM_error(WARNING, "negative buoyancy freq") + renorm_N = renorm_N + (sqrt(max(N2_lay(i,k), 0.)) * h(i,j,k)) + ! N2-profile + renorm_N2 = renorm_N2 + (max(N2_lay(i,k), 0.) * h(i,j,k)) + ! total depth + htot = htot + h(i,j,k) + enddo + + profile_N2(:) = 0.0 + profile_N(:) = 0.0 + profile_BBL(:) = 0.0 + profile_StLaurent(:) = 0.0 + profile_StLaurent_slope(:) = 0.0 + + ! BBL-profile + h_rmn = h_bot(i) + do k=nz,1,-1 + if (G%mask2dT(i,j) > 0.0) then + profile_BBL(k) = 0.0 + if (h(i,j,k) <= h_rmn) then + profile_BBL(k) = 1.0 / h_bot(i) + h_rmn = h_rmn - h(i,j,k) + else + if (h_rmn > 0.0) then + frac = h_rmn / h(i,j,k) + profile_BBL(k) = frac / h_bot(i) + h_rmn = h_rmn - frac*h(i,j,k) + endif + endif + endif + enddo + + do k=1,nz + if (G%mask2dT(i,j) > 0.0) then + ! N - profile + if (renorm_N > threshold_renorm_N) then + profile_N(k) = sqrt(max(N2_lay(i,k), 0.)) / renorm_N + else + profile_N(k) = 1 / htot + endif + + ! N2 - profile + if (renorm_N2 > threshold_renorm_N2) then + profile_N2(k) = max(N2_lay(i,k), 0.) / renorm_N2 + else + profile_N2(k) = 1 / htot + endif + + ! slope intensified (St Laurent GRL 2002) - profile + ! in paper, z is defined positive upwards, range 0 to -H + ! here depth positive downwards + ! profiles are almost normalized but differ from a few percent + ! so we add a second renormalization factor + + ! add first half of layer: get to the layer center + htmp = htmp + 0.5*h(i,j,k) + + profile_StLaurent(k) = exp(-I_h_d*(htot-htmp)) / & + (h_d*(1 - exp(-I_h_d*htot))) + + profile_StLaurent_slope(k) = exp(-I_h_s*(htot-htmp)) / & + (h_s*(1 - exp(-I_h_s*htot))) + + tmp_StLau = tmp_StLau + (profile_StLaurent(k) * h(i,j,k)) + tmp_StLau_slope = tmp_StLau_slope + (profile_StLaurent_slope(k) * h(i,j,k)) + + ! add second half of layer: get to the next interface + htmp = htmp + 0.5*h(i,j,k) + endif + enddo + + if (G%mask2dT(i,j) > 0.0) then + ! allow for difference less than verification threshold + renorm_StLau = 1.0 + renorm_StLau_slope = 1.0 + if (abs(tmp_StLau -1.0) > threshold_verif) renorm_StLau = 1.0 / tmp_StLau + if (abs(tmp_StLau_slope -1.0) > threshold_verif) renorm_StLau_slope = 1.0 / tmp_StLau_slope + + do k=1,nz + profile_StLaurent(k) = profile_StLaurent(k) * renorm_StLau + profile_StLaurent_slope(k) = profile_StLaurent_slope(k) * renorm_StLau_slope + enddo + endif + + ! verif integrals + if (CS%debug) then + if (G%mask2dT(i,j) > 0.0) then + verif_N = 0.0 + verif_N2 = 0.0 + verif_bbl = 0.0 + verif_stl1 = 0.0 + verif_stl2 = 0.0 + do k=1,nz + verif_N = verif_N + (profile_N(k) * h(i,j,k)) + verif_N2 = verif_N2 + (profile_N2(k) * h(i,j,k)) + verif_bbl = verif_bbl + (profile_BBL(k) * h(i,j,k)) + verif_stl1 = verif_stl1 + (profile_StLaurent(k) * h(i,j,k)) + verif_stl2 = verif_stl2 + (profile_StLaurent_slope(k) * h(i,j,k)) + enddo + + if (abs(verif_N -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_N + call MOM_error(FATAL, "mismatch integral for N profile") + endif + if (abs(verif_N2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_N2 + call MOM_error(FATAL, "mismatch integral for N2 profile") + endif + if (abs(verif_bbl -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_bbl + call MOM_error(FATAL, "mismatch integral for bbl profile") + endif + if (abs(verif_stl1 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl1 + call MOM_error(FATAL, "mismatch integral for stl1 profile") + endif + if (abs(verif_stl2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl2 + call MOM_error(FATAL, "mismatch integral for stl2 profile") + endif + + endif + endif + + ! note on units: TKE_to_Kd = 1 / ((g/rho0) * drho) Z-1 T2 + ! mult by dz gives -1/N2 in T2 + + ! get TKE loss value and compute diffusivites in layers + if (CS%apply_background_drag) then + call get_lowmode_loss(i, j, G, CS, "LeakDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%leak_profile) == "N2" then + profile_leak(i,:) = profile_N2(:) + ! elseif trim(CS%leak_profile) == "N" then + ! profile_leak(:) = profile_N(:) + ! something else + ! endif + Kd_leak_lay(:) = 0. + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_leak_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + else + Kd_leak_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_leak_lay(k), Kd_max) + enddo + endif + + if (CS%apply_Froude_drag) then + call get_lowmode_loss(i, j, G, CS, "Froude", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%Froude_profile) == "N" then + profile_Froude(i,:) = profile_N(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_Froude(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_Froude_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + else + Kd_Froude_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_Froude_lay(k), Kd_max) + enddo + endif + + if (CS%apply_wave_drag) then + call get_lowmode_loss(i, j, G, CS, "WaveDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_itidal(i,:) = profile_StLaurent(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_itidal_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + else + Kd_itidal_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_itidal_lay(k), Kd_max) + enddo + endif + + if (CS%apply_residual_drag) then + call get_lowmode_loss(i, j, G, CS, "SlopeDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_slope(i,:) = profile_StLaurent_slope(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_slope_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + else + Kd_slope_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_slope_lay(k), Kd_max) + enddo + endif + + if (CS%apply_bottom_drag) then + call get_lowmode_loss(i, j, G, CS, "QuadDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%bottom_profile) == "BBL" then + profile_quad(i,:) = profile_BBL(:) + ! elseif trim(CS%bottom_profile) == "N2" then + ! profile_quad(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_quad_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + else + Kd_quad_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_quad_lay(k), Kd_max) + enddo + endif + + ! interpolate Kd_[] to interfaces and add to Kd_int + if (CS%apply_background_drag) then + do k=1,nz+1 + if (k>1) Kd_leak(i,K) = 0.5*Kd_leak_lay(k-1) + if (k1) Kd_itidal(i,K) = 0.5*Kd_itidal_lay(k-1) + if (k1) Kd_Froude(i,K) = 0.5*Kd_Froude_lay(k-1) + if (k1) Kd_slope(i,K) = 0.5*Kd_slope_lay(k-1) + if (k1) Kd_quad(i,K) = 0.5*Kd_quad_lay(k-1) + if (k Implements refraction on the internal waves at a single frequency. subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1052,7 +1807,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. @@ -1063,13 +1818,14 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & - En2d ! The internal gravity wave energy density in zonal slices [R Z3 T-2 ~> J m-2] + En2d ! The internal gravity wave energy density in zonal slices [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(1-stencil:NAngle+stencil) :: & cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(SZI_(G)) :: & Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] real, dimension(SZI_(G),0:nAngle) :: & - Flux_E ! The flux of energy between successive angular wedges within a timestep [R Z3 T-2 ~> J m-2] + Flux_E ! The flux of energy between successive angular wedges + ! within a timestep [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & CFL_ang ! The CFL number of angular refraction [nondim] real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] @@ -1099,15 +1855,15 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) do j=js,je ; do I=is-1,ie ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 ! and wgt = 1 if neighbour cn == 0 - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - wgt2 = cnmask(i+1,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + wgt2 = cnmask(i+1,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + cn_u(I,j) = (wgt1*cn(i,j)) + (wgt2*cn(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + wgt2 = cnmask(i,j+1) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + cn_v(i,J) = (wgt1*cn(i,j)) + (wgt2*cn(i,j+1)) enddo ; enddo Ifreq = 1.0 / freq @@ -1138,10 +1894,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) - df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * G%IdxT(i,j) - df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & - (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * G%IdyT(i,j) + df_dx = 0.5*G%IdxT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) - G%CoriolisBu(I-1,J))) + df_dy = 0.5*G%IdyT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) - G%CoriolisBu(I,J-1))) dlnCn_dx = G%IdxT(i,j) * (cn_u(I,j) - cn_u(I-1,j)) / (0.5 * (cn_u(I,j) + cn_u(I-1,j)) + cn_subRO) dlnCn_dy = G%IdyT(i,j) * (cn_v(i,J) - cn_v(i,J-1)) / (0.5 * (cn_v(i,J) + cn_v(i,J-1)) + cn_subRO) @@ -1159,10 +1915,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Determine the energy fluxes in angular orientation space. do A=asd,aed ; do i=is,ie - CFL_ang(i,j,A) = (cos_angle(A) * Dl_Dt_Kmag(i) - sin_angle(A) * Dk_Dt_Kmag(i)) * dt_Angle_size + CFL_ang(i,j,A) = ((cos_angle(A) * Dl_Dt_Kmag(i)) - (sin_angle(A) * Dk_Dt_Kmag(i))) * dt_Angle_size if (abs(CFL_ang(i,j,A)) > 1.0) then call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) - if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif + if (CFL_ang(i,j,A) > 1.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif enddo ; enddo @@ -1202,25 +1958,25 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a - !! function of angular resolution [R Z3 T-2 ~> J m-2]. + !! function of angular resolution [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux - !! across angles [R Z3 T-2 ~> J m-2]. + !! across angles [H Z2 T-2 ~> m3 s-2 or J m-2]. ! Local variables - real :: flux ! The internal wave energy flux across angles [R Z3 T-3 ~> W m-2]. + real :: flux ! The internal wave energy flux across angles [H Z2 T-3 ~> m3 s-3 or W m-2]. real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] 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 :: aR, aL ! Left and right edge estimates of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] 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] + ! orientation [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] integer :: a - I_dt = 1 / dt + I_dt = 1.0 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) I_Angle_size = 1 / Angle_size Flux_En(:) = 0 @@ -1230,7 +1986,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) if (u_ang >= 0.0) then ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+1)*I_Angle_size Ec = En2d(a) *I_Angle_size Em = En2d(a-1)*I_Angle_size @@ -1248,15 +2004,15 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] flux = u_ang*( aR + CFL_ang(A) * ( 0.5*(aL - aR) + curv_3 * (CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+2)*I_Angle_size Ec = En2d(a+1)*I_Angle_size Em = En2d(a) *I_Angle_size @@ -1274,10 +2030,10 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] ! Note that CFL_ang is negative here, so it looks odd compared with equivalent expressions. flux = u_ang*( aL - CFL_ang(A) * ( 0.5*(aR - aL) + curv_3 * (-CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif @@ -1285,23 +2041,24 @@ 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, residual_loss) +subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) 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) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or 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]. @@ -1326,7 +2083,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) type(loop_bounds_type) :: LB integer :: is, ie, js, je, asd, aed, na integer :: ish, ieh, jsh, jeh - integer :: i, j, a + integer :: i, j, a, fr, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil @@ -1348,6 +2105,13 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Angle_size = (8.0*atan(1.0)) / real(NAngle) I_Angle_size = 1.0 / Angle_size + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: top of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: top of routine', CS%En_sum + enddo ; enddo + endif + if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS @@ -1359,6 +2123,9 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) 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 + + call pass_var(speed, G%Domain) + do a=1,na ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie @@ -1384,35 +2151,76 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Cgy_av(a)**2) enddo + speed_x(:,:) = 0. do j=jsh,jeh ; do I=ish-1,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + + speed_y(:,:) = 0. do J=jsh-1,jeh ; do i=ish,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) + call pass_var(En, G%domain) + ! 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, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_x') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_x', CS%En_sum + enddo ; enddo + endif ! Update halos call pass_var(En, G%domain) call pass_var(residual_loss, G%domain) + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after halo update', CS%En_sum + enddo ; enddo + endif ! 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, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_y') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_y') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_y', CS%En_sum + enddo ; enddo + endif + + endif + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: bottom of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: bottom of routine', CS%En_sum + enddo ; enddo endif end subroutine propagate @@ -1424,7 +2232,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & intent(in) :: speed !< The magnitude of the group velocity at the cell !! corner points [L T-1 ~> m s-1]. @@ -1462,7 +2270,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] - real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size + real, dimension(2) :: E_new ! Energy in cell after advection for subray [H Z2 T-2 ~> m3 s-2 or J m-2]; set size ! here to define Nsubrays - this should be made an input option later! ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1715,7 +2523,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. @@ -1728,17 +2536,17 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res 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]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or 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]. + EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_x ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZIB_(G)) :: & cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the x-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the x-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! Left and right energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1763,12 +2571,15 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res enddo 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))) + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + 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))) + endif enddo ; enddo enddo ! a-loop @@ -1780,11 +2591,9 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") - En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + En(i,j,a) = En(i,j,a) + (G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) enddo ; enddo ; enddo end subroutine propagate_x @@ -1796,7 +2605,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. @@ -1809,17 +2618,17 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res 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]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or 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]. + EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_y ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZI_(G)) :: & cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the y-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the y-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! South and north energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1844,19 +2653,15 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res enddo 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), & - ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) - ! call MOM_error(WARNING, mesg, .true.) - !endif + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + 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))) + endif enddo ; enddo enddo ! a-loop @@ -1868,10 +2673,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) enddo ; enddo ; enddo @@ -1882,12 +2685,12 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZIB_(G)), intent(out) :: uh !< The zonal energy transport [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-index to work on. @@ -1897,7 +2700,7 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) !! the cell areas when estimating the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do I=ish-1,ieh @@ -1925,12 +2728,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes [R Z3 T-2 ~> J m-2]. + !! fluxes [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: vh !< The meridional energy transport + !! [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: J !< The j-index to work on. @@ -1941,7 +2745,7 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) !! the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do i=ish,ieh @@ -1971,7 +2775,7 @@ subroutine reflect(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1983,7 +2787,7 @@ subroutine reflect(En, NAngle, CS, G, LB) ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge ! tags of cells with double reflection - real, dimension(1:Nangle) :: En_reflected ! Energy reflected [R Z3 T-2 ~> J m-2]. + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] @@ -2078,7 +2882,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables @@ -2096,7 +2900,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] - real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] + real :: En_tele ! energy to be "teleported" [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain @@ -2171,7 +2975,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, - !! and vertical mode [R Z3 T-2 ~> J m-2]. + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the @@ -2181,7 +2985,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density - ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new integer :: a, i, j, ish, ieh, jsh, jeh, m, fr @@ -2228,19 +3032,23 @@ end subroutine correct_halo_rotation !> Calculates left/right edge values for PPM reconstruction in x-direction. subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_ip1, h_im1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2303,19 +3111,23 @@ end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_jp1, h_jm1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2379,18 +3191,22 @@ end subroutine PPM_reconstruction_y !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] real, intent(in) :: h_min !< The minimum value that can be - !! obtained by a concave parabolic fit [R Z3 T-2 ~> J m-2] + !! obtained by a concave parabolic fit + !! [H Z2 T-2 ~> m3 s-2 or J m-2] integer, intent(in) :: iis !< Start i-index for computations integer, intent(in) :: iie !< End i-index for computations integer, intent(in) :: jis !< Start j-index for computations integer, intent(in) :: jie !< End j-index for computations ! Local variables - real :: curv ! The cell-area normalized curvature [R Z3 T-2 ~> J m-2] - real :: dh ! The difference between the edge values [R Z3 T-2 ~> J m-2] + real :: curv ! The cell-area normalized curvature [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dh ! The difference between the edge values [H Z2 T-2 ~> m3 s-2 or J m-2] real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] integer :: i, j @@ -2415,8 +3231,9 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) +subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type),intent(in):: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: CS !< Internal tide control structure @@ -2424,16 +3241,22 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! 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 :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_int_tides integer :: num_freq, num_angle , num_mode, period_1 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr - character(64) :: var_name, cfr + character(64) :: var_name, cfr, units type(axis_info) :: axes_inttides(2) real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + HZ2_T2_to_J_m2 = GV%H_to_MKS*(US%Z_to_m**2)*(US%s_to_T**2) + if (associated(CS)) then call MOM_error(WARNING, "register_int_tide_restarts called "//& "with an associated control structure.") @@ -2447,6 +3270,19 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + ! define restart units depemding on Boussinesq + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) + + units="J m-2" + if (non_Bous) units="m3 s-2" + allocate (angles(num_angle)) allocate (freqs(num_freq)) @@ -2473,7 +3309,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! register all 4d restarts and copy into full Energy array when restarting from previous state call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2483,7 +3319,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 2) then call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2495,7 +3331,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 3) then call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2507,7 +3343,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 4) then call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2519,7 +3355,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 5) then call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2533,7 +3369,7 @@ end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -2558,6 +3394,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] real :: period ! A tidal period read from namelist [T ~> s] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2579,6 +3419,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + CS%initialized = .true. use_int_tides = .false. @@ -2615,11 +3460,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%frequency(num_freq)) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! The periods of the tidal constituents for internal tides raytracing call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - period = extract_real(periods, " ,", fr, 0.) + period = US%s_to_T*extract_real(periods, " ,", fr, 0.) if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") CS%frequency(fr) = 8.0*atan(1.0)/period enddo @@ -2669,6 +3518,30 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag + call get_param(param_file, mdl, "INTERNAL_TIDES_UPDATE_KD", CS%update_Kd, & + "If true, internal tides ray tracing changes Kd for dynamics.", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_REFRACTION", CS%apply_refraction, & + "If true, internal tides ray tracing does refraction.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_PROPAGATION", CS%apply_propagation, & + "If true, internal tides ray tracing does propagate.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, & + "If true, internal tides ray tracing only applies forcing at first step (debugging).", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, & + "If true, force energy to be positive by removing subroundoff negative values.", & + default=.true.) + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=2e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MINTHICK_TKE_TO_KD", CS%min_thick_layer_Kd, & + "The minimum thickness allowed with TKE_to_Kd.", & + units="m", default=1e-6, scale=GV%m_to_H) + call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & + "Limiter for TKE_to_Kd.", & + units="", default=1e9, scale=US%Z_to_m*US%s_to_T**2) call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", & @@ -2703,7 +3576,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "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", & + "If true, apply drag due to critical slopes", & 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 "//& @@ -2714,10 +3587,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply wave breaking as a sink.", & default=.false.) call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & - "An energy density tolerance for flagging points with an imbalance in the "//& - "internal tide energy budget when INTERNAL_TIDE_FROUDE_DRAG is True.", & - units="J m-2", default=1.0e-10, scale=US%W_m2_to_RZ3_T3*US%s_to_T, & + "An energy density tolerance for flagging points with small negative "//& + "internal tide energy.", & + units="J m-2", default=1.0, scale=J_m2_to_HZ2_T2, & do_not_log=.not.CS%apply_Froude_drag) + call get_param(param_file, mdl, "EN_UNDERFLOW", CS%En_underflow, & + "A small energy density below which Energy is set to zero.", & + units="J m-2", default=1.0e-100, scale=J_m2_to_HZ2_T2) + call get_param(param_file, mdl, "EN_RESTART_POWER", CS%En_restart_power, & + "A power factor to save larger values x 2**(power) in restart files.", & + units="nondim", default=0) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", & @@ -2731,7 +3610,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& "See REMAPPING_USE_OM4_SUBCELLS for details. "//& "We recommend setting this option to false.", default=.true.) - call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & "If positive, a uniform group velocity of internal tide for test case", & default=-1., units="m s-1", scale=US%m_s_to_L_T) @@ -2753,6 +3631,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "GAMMA_OSBORN", CS%gamma_osborn, & + "The mixing efficiency for internan tides from Osborn 1980 ", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & + "The decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=500.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE_SLOPES", CS%Int_tide_decay_scale_slope, & + "The slope decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=100.0, scale=GV%m_to_H) ! Allocate various arrays needed for loss rates allocate(h2(isd:ied,jsd:jed), source=0.0) @@ -2762,6 +3651,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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%TKE_slope_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) @@ -2774,6 +3664,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) + allocate(CS%error_mode(num_freq,num_mode), source=0.0) + allocate(CS%En_ini_glo(num_freq,num_mode), source=0.0) + allocate(CS%En_end_glo(num_freq,num_mode), source=0.0) + allocate(CS%TKE_leak_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_quad_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_Froude_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_itidal_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_input_glo_dt(num_freq,num_mode), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2799,7 +3698,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) endif ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here ! will be multiplied by N and the squared near-bottom velocity (and by the - ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + ! near-bottom density in non-Boussinesq mode) to get into [H Z2 T-3 ~> m3 s-3 or W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo @@ -2888,12 +3787,23 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! residual allocate(CS%residual(isd:ied,jsd:jed), source=0.0) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (CS%refl_pref_logical(i,j)) then - CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) - endif - enddo ; enddo - call pass_var(CS%residual, G%domain) + if (CS%apply_residual_drag) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - (CS%refl_pref(i,j) - CS%trans(i,j)) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) + else + ! report residual of transmission/reflection onto reflection + ! this ensure energy budget is conserved + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%refl_pref(i,j) = 1. - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%refl_pref, G%domain) + endif CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) @@ -2933,7 +3843,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & - 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + 'J m-2', conversion=HZ2_T2_to_J_m2) allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) @@ -2944,27 +3854,27 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & Time, 'Internal tide energy loss to bottom drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) 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) + 'W m-2', conversion=HZ2_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) + 'W m-2', conversion=HZ2_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) + 'W m-2', conversion=HZ2_T3_to_W_m2) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) @@ -2996,14 +3906,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + diag%axesT1, Time, var_descript, 'J m-2', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy density for each frequency and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D energy loss (summed over angles) for each frequency and mode @@ -3011,37 +3921,37 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Leakage loss write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Quad loss write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Froude loss write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! residual losses write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy loss for each frequency and mode @@ -3049,7 +3959,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6631298690..c5297a3cf0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3588,8 +3588,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init !> Routine to register restarts, pass-through to children modules -subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) +subroutine register_diabatic_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure @@ -3602,7 +3603,7 @@ subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_C call read_param(param_file, "INTERNAL_TIDES", use_int_tides) if (use_int_tides) then - call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + call register_int_tide_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) endif end subroutine register_diabatic_restarts diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index aa02a42ea9..f4ef901868 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -42,8 +42,8 @@ module MOM_int_tide_input logical :: debug !< If true, write verbose checksums for debugging. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [R Z3 T-3 ~> W m-2] + real :: TKE_itide_maxi !< Maximum Internal tide conversion + !! available to mix above the BBL [H Z2 T-3 ~> m3 s-3 or W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -51,7 +51,7 @@ module MOM_int_tide_input !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. real, allocatable, dimension(:,:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [H Z2 T-3 ~> m3 s-3 or W m-2]. tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. character(len=200) :: inputdir !< The directory for input files. @@ -105,7 +105,9 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + Rho_bot, & ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + h_bot ! Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZJ_(G)) :: k_bot ! Bottom boundary layer top layer index. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in @@ -114,11 +116,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! equation of state. logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global integer :: fr + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + 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 @@ -135,7 +142,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) + call find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, itide%h2, N2_bot, Rho_bot, h_bot, k_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -143,15 +150,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min(GV%RZ_to_H*GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo else !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & - CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo endif @@ -163,7 +171,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo else @@ -171,7 +179,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo endif @@ -181,7 +189,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%debug) then call hchksum(N2_bot, "N2_bot", G%HI, haloshift=0, unscale=US%s_to_T**2) call hchksum(CS%TKE_itidal_input,"TKE_itidal_input", G%HI, haloshift=0, & - unscale=US%RZ3_T3_to_W_m2) + unscale=HZ2_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) @@ -198,23 +206,26 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) +subroutine find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, h2, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to !! smooth out the values in thin layers [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to !! smooth out the values in thin layers [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. - type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Rho_bot !< The average density near the ocean !! bottom [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZJ_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. @@ -247,7 +258,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & - !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP h2,N2_bot,Rho_bot,h_bot,k_bot,G_Rho0,EOSdom) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & !$OMP firstprivate(dRho_int) @@ -324,7 +335,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo else ! Average the density over the envelope of the topography. - call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, h_amp, j, Rho_bot(:,j), h_bot(:,j), k_bot(:,j)) endif enddo @@ -334,7 +345,8 @@ end subroutine find_N2_bottom subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). real, dimension(SZI_(G),SZJ_(G),nFreq), & - intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + intent(out) :: TKE_itidal_input !< The energy input to the internal waves + !! [H Z2 T-3 ~> m3 s-3 or W m-2]. integer, intent(in) :: nFreq !< number of frequencies type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. @@ -392,6 +404,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -417,6 +431,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%diag => diag + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -455,10 +472,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) - call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_maxi, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + units="W m-2", default=1.0e3, scale=W_m2_to_HZ2_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -551,7 +568,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 4efee8d561..9a87b085a6 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,7 +23,7 @@ module MOM_set_diffusivity use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom -use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss, get_lowmode_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data use MOM_isopycnal_slopes, only : vert_fill_TS @@ -148,6 +148,7 @@ module MOM_set_diffusivity logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. + logical :: use_int_tides !< If true, use internal tides ray tracing logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] @@ -176,8 +177,11 @@ module MOM_set_diffusivity !>@{ Diagnostic IDs integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 - integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 - integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1, id_Kd_leak = -1 + integer :: id_Kd_quad = -1, id_Kd_itidal = -1, id_Kd_Froude = -1, id_Kd_slope = -1 + integer :: id_prof_leak = -1, id_prof_quad = -1, id_prof_itidal= -1 + integer :: id_prof_Froude= -1, id_prof_slope = -1, id_bbl_thick = -1, id_kbbl = -1 !>@} end type set_diffusivity_CS @@ -185,16 +189,29 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] - KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + drho_rat => NULL(), & !< The density difference ratio used in double diffusion [nondim]. + Kd_leak => NULL(), & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad => NULL(), & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal => NULL(), & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude => NULL(), & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope => NULL(), & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + prof_leak => NULL(), & !< vertical profile for leakage [H-1 ~> m-1 or m2 kg-1] + prof_quad => NULL(), & !< vertical profile for bottom drag [H-1 ~> m-1 or m2 kg-1] + prof_itidal => NULL(), & !< vertical profile for wave drag [H-1 ~> m-1 or m2 kg-1] + prof_Froude => NULL(), & !< vertical profile for Froude drag [H-1 ~> m-1 or m2 kg-1] + prof_slope => NULL() !< vertical profile for critical slopes [H-1 ~> m-1 or m2 kg-1] + real, pointer, dimension(:,:) :: bbl_thick => NULL(), & !< bottom boundary layer thickness [H ~> m or kg m-2] + kbbl => NULL() !< top of bottom boundary layer + real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer @@ -252,6 +269,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! local variables real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] + real :: h_bot(SZI_(G)) ! Bottom boundary layer thickness [H ~> m or kg m-2] + integer :: k_bot(SZI_(G)) ! Bottom boundary layer thickness top layer index type(diffusivity_diags) :: dd ! structure with arrays of available diags @@ -264,6 +283,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dz, & !< Height change across layers [Z ~> m] maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + prof_leak_2d, & !< vertical profile for leakage [Z-1 ~> m-1] + prof_quad_2d, & !< vertical profile for bottom drag [Z-1 ~> m-1] + prof_itidal_2d, & !< vertical profile for wave drag [Z-1 ~> m-1] + prof_Froude_2d, & !< vertical profile for Froude drag [Z-1 ~> m-1] + prof_slope_2d, & !< vertical profile for critical slopes [Z-1 ~> m-1] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] @@ -272,6 +296,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] + Kd_leak_2d, & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad_2d, & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal_2d, & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude_2d, & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope_2d, & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -316,6 +345,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + CS%use_int_tides .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) ! Set Kd_lay, Kd_int and Kv_slow to constant values, mostly to fill the halos. @@ -342,6 +372,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) allocate(dd%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) if (CS%id_Kv_bkgnd > 0) allocate(dd%Kv_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_kbbl > 0) allocate(dd%kbbl(isd:ied,jsd:jed), source=0.) + if (CS%id_bbl_thick > 0) allocate(dd%bbl_thick(isd:ied,jsd:jed), source=0.) + if (CS%id_Kd_leak > 0) allocate(dd%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_quad > 0) allocate(dd%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_itidal > 0) allocate(dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_Froude > 0) allocate(dd%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_slope > 0) allocate(dd%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.) + + if (CS%id_prof_leak > 0) allocate(dd%prof_leak(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_quad > 0) allocate(dd%prof_quad(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_itidal > 0) allocate(dd%prof_itidal(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_Froude > 0) allocate(dd%prof_Froude(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_slope > 0) allocate(dd%prof_slope(isd:ied,jsd:jed,nz), source=0.) + ! set up arrays for tidal mixing diagnostics if (CS%use_tidal_mixing) & call setup_tidal_diagnostics(G, GV, CS%tidal_mixing) @@ -406,12 +450,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! parameterization of Kd. !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & - !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & + !$OMP N2_bot,rho_bot,h_bot,k_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot, h_bot, k_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -520,6 +564,53 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) + ! Add diffusivity from internal tides ray tracing + if (CS%use_int_tides) then + + call get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, CS%Kd_max, & + CS%int_tide_CSp, Kd_leak_2d, Kd_quad_2d, Kd_itidal_2d, Kd_Froude_2d, Kd_slope_2d, & + Kd_lay_2d, Kd_int_2d, prof_leak_2d, prof_quad_2d, prof_itidal_2d, prof_froude_2d, & + prof_slope_2d) + + if (CS%id_kbbl > 0) then ; do i=is,ie + dd%kbbl(i,j) = k_bot(i) + enddo ; endif + if (CS%id_bbl_thick > 0) then ; do i=is,ie + dd%bbl_thick(i,j) = h_bot(i) + enddo ; endif + if (CS%id_Kd_leak > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_leak(i,j,K) = Kd_leak_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_quad > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_itidal > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_Froude > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_slope > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + enddo ; enddo ; endif + + if (CS%id_prof_leak > 0) then ; do k=1,nz; do i=is,ie + dd%prof_leak(i,j,k) = prof_leak_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_quad > 0) then ; do k=1,nz; do i=is,ie + dd%prof_quad(i,j,k) = prof_quad_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_itidal > 0) then ; do k=1,nz; do i=is,ie + dd%prof_itidal(i,j,k) = prof_itidal_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_Froude > 0) then ; do k=1,nz; do i=is,ie + dd%prof_Froude(i,j,k) = prof_Froude_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_slope > 0) then ; do k=1,nz; do i=is,ie + dd%prof_slope(i,j,k) = prof_slope_2d(i,k) + enddo ; enddo ; endif + endif + ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then @@ -624,6 +715,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif + if (CS%debug) then + if (CS%id_prof_leak > 0) call hchksum(dd%prof_leak, "leakage_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_slope > 0) call hchksum(dd%prof_slope, "slope_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_Froude > 0) call hchksum(dd%prof_Froude, "Froude_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_quad > 0) call hchksum(dd%prof_quad, "quad_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_itidal > 0) call hchksum(dd%prof_itidal, "itidal_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_TKE_to_Kd > 0) call hchksum(dd%TKE_to_Kd, "TKE_to_Kd", G%HI, haloshift=0, scale=US%m_to_Z*US%T_to_s**2) + if (CS%id_Kd_leak > 0) call hchksum(dd%Kd_leak, "Kd_leak", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_quad > 0) call hchksum(dd%Kd_quad, "Kd_quad", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_itidal > 0) call hchksum(dd%Kd_itidal, "Kd_itidal", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_Froude > 0) call hchksum(dd%Kd_Froude, "Kd_Froude", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_slope > 0) call hchksum(dd%Kd_slope, "Kd_slope", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + ! post diagnostics if (present(Kd_lay) .and. (CS%id_Kd_layer > 0)) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) @@ -631,6 +736,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) call post_data(CS%id_Kd_bkgnd, dd%Kd_bkgnd, CS%diag) if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) + if (CS%id_kbbl > 0) call post_data(CS%id_kbbl, dd%kbbl, CS%diag) + if (CS%id_bbl_thick > 0) call post_data(CS%id_bbl_thick, dd%bbl_thick, CS%diag) + if (CS%id_Kd_leak > 0) call post_data(CS%id_Kd_leak, dd%Kd_leak, CS%diag) + if (CS%id_Kd_slope > 0) call post_data(CS%id_Kd_slope, dd%Kd_slope, CS%diag) + if (CS%id_Kd_Froude > 0) call post_data(CS%id_Kd_Froude, dd%Kd_Froude, CS%diag) + if (CS%id_Kd_quad > 0) call post_data(CS%id_Kd_quad, dd%Kd_quad, CS%diag) + if (CS%id_Kd_itidal > 0) call post_data(CS%id_Kd_itidal, dd%Kd_itidal, CS%diag) + + if (CS%id_prof_leak > 0) call post_data(CS%id_prof_leak, dd%prof_leak, CS%diag) + if (CS%id_prof_slope > 0) call post_data(CS%id_prof_slope, dd%prof_slope, CS%diag) + if (CS%id_prof_Froude > 0) call post_data(CS%id_prof_Froude, dd%prof_Froude, CS%diag) + if (CS%id_prof_quad > 0) call post_data(CS%id_prof_quad, dd%prof_quad, CS%diag) + if (CS%id_prof_itidal > 0) call post_data(CS%id_prof_itidal, dd%prof_itidal, CS%diag) + ! tidal mixing if (CS%use_tidal_mixing) & call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing) @@ -665,6 +784,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) + if (associated(dd%Kd_leak)) deallocate(dd%Kd_leak) + if (associated(dd%Kd_quad)) deallocate(dd%Kd_quad) + if (associated(dd%Kd_itidal)) deallocate(dd%Kd_itidal) + if (associated(dd%Kd_Froude)) deallocate(dd%Kd_Froude) + if (associated(dd%Kd_slope)) deallocate(dd%Kd_slope) + if (associated(dd%prof_leak)) deallocate(dd%prof_leak) + if (associated(dd%prof_quad)) deallocate(dd%prof_quad) + if (associated(dd%prof_itidal)) deallocate(dd%prof_itidal) + if (associated(dd%prof_Froude)) deallocate(dd%prof_Froude) + if (associated(dd%prof_slope)) deallocate(dd%prof_slope) + if (showCallTree) call callTree_leave("set_diffusivity()") end subroutine set_diffusivity @@ -895,7 +1025,7 @@ end subroutine find_TKE_to_Kd !> Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot, Rho_bot) + N2_lay, N2_int, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -921,6 +1051,8 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), optional, intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G)), optional, intent(out) :: k_bot !< Bottom boundary layer top layer index. ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -1065,7 +1197,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & ! Average over the larger of the envelope of the topography or a minimal distance. do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo - call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, dz_BBL_avg, j, Rho_bot, h_bot, k_bot) end subroutine find_N2 @@ -2071,7 +2203,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version @@ -2116,7 +2248,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + CS%int_tide_CSp => int_tide_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. @@ -2273,6 +2405,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "for an isopycnal layer-formulation.", & default=.false., do_not_log=.not.TKE_to_Kd_used) + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & + "If true, use the code that advances a separate set of "//& + "equations for the internal tide energy density.", default=.false.) + ! set parameters related to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) @@ -2350,6 +2486,33 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + if (CS%use_int_tides) then + CS%id_kbbl = register_diag_field('ocean_model', 'kbbl', diag%axesT1, Time, & + 'BBL index at h points', 'nondim') + CS%id_bbl_thick = register_diag_field('ocean_model', 'bbl_thick', diag%axesT1, Time, & + 'BBL thickness at h points', 'm', conversion=US%Z_to_m) + CS%id_Kd_leak = register_diag_field('ocean_model', 'Kd_leak', diag%axesTi, Time, & + 'internal tides leakage viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_Froude = register_diag_field('ocean_model', 'Kd_Froude', diag%axesTi, Time, & + 'internal tides Froude viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_itidal = register_diag_field('ocean_model', 'Kd_itidal', diag%axesTi, Time, & + 'internal tides wave drag viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_quad = register_diag_field('ocean_model', 'Kd_quad', diag%axesTi, Time, & + 'internal tides bottom viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_slope = register_diag_field('ocean_model', 'Kd_slope', diag%axesTi, Time, & + 'internal tides slope viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_prof_leak = register_diag_field('ocean_model', 'prof_leak', diag%axesTl, Time, & + 'internal tides leakage profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_Froude = register_diag_field('ocean_model', 'prof_Froude', diag%axesTl, Time, & + 'internal tides Froude profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_itidal = register_diag_field('ocean_model', 'prof_itidal', diag%axesTl, Time, & + 'internal tides wave drag profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_quad = register_diag_field('ocean_model', 'prof_quad', diag%axesTl, Time, & + 'internal tides bottom profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_slope = register_diag_field('ocean_model', 'prof_slope', diag%axesTl, Time, & + 'internal tides slope profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + endif + CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) From 95744a71bf558c9802d02ee8562d6c1d1c147c83 Mon Sep 17 00:00:00 2001 From: Chengzhu Xu <135884058+c2xu@users.noreply.github.com> Date: Tue, 10 Sep 2024 09:16:08 -0600 Subject: [PATCH 081/128] Streaming filter (#675) In the MOM_streaming_filter module, a system of two coupled ODEs is configured as a streaming band-pass filter that takes the broadband model output as the input and returns the filtered signal at a user specified tidal frequency as the output. It is capable of detecting the instantaneous tidal signals while the model is running, and can be used to impose frequency-dependent wave drag or to de-tide model output. An example of filtering the M2 and K1 barotropic velocities is provided in the MOM_barotropic module. Added runtime flags for the M2 and K1 filters. Simplified the code by removing the control structure of the linked list, and now each filter has its own control structure. Using hor_index_type argument to avoid calculation in halo regions. --- src/core/MOM_barotropic.F90 | 70 +++++++++++ .../lateral/MOM_streaming_filter.F90 | 119 ++++++++++++++++++ 2 files changed, 189 insertions(+) create mode 100644 src/parameterizations/lateral/MOM_streaming_filter.F90 diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e97e794cd6..0ac3e52a62 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -26,6 +26,8 @@ module MOM_barotropic use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_self_attr_load, only : scalar_SAL_sensitivity use MOM_self_attr_load, only : SAL_CS +use MOM_streaming_filter, only : Filt_register, Filt_accum, Filter_CS +use MOM_tidal_forcing, only : tidal_frequency use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type @@ -248,6 +250,10 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. + logical :: use_filter_m2 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. + logical :: use_filter_k1 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. logical :: use_wide_halos !< If true, use wide halos and march in during the !! barotropic time stepping for efficiency. logical :: clip_velocity !< If true, limit any velocity components that are @@ -291,6 +297,10 @@ module MOM_barotropic type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis + type(Filter_CS) :: Filt_CS_um2, & !< Control structures for the M2 streaming filter + Filt_CS_vm2, & !< Control structures for the M2 streaming filter + Filt_CS_uk1, & !< Control structures for the K1 streaming filter + Filt_CS_vk1 !< Control structures for the K1 streaming filter logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -598,6 +608,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. + real, dimension(:,:), pointer :: um2, uk1, vm2, vk1 + ! M2 and K1 velocities from the output of streaming filters [m s-1] real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & eta, & ! The barotropic free surface height anomaly or column mass ! anomaly [H ~> m or kg m-2] @@ -1586,6 +1598,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo endif + ! Here is an example of how the filter equations are time stepped to determine the M2 and K1 velocities. + ! The filters are initialized and registered in subroutine barotropic_init. + if (CS%use_filter_m2) then + call Filt_accum(ubt, um2, CS%Time, US, CS%Filt_CS_um2) + call Filt_accum(vbt, vm2, CS%Time, US, CS%Filt_CS_vm2) + endif + if (CS%use_filter_k1) then + call Filt_accum(ubt, uk1, CS%Time, US, CS%Filt_CS_uk1) + call Filt_accum(vbt, vk1, CS%Time, US, CS%Filt_CS_vk1) + endif + ! Zero out the arrays for various time-averaged quantities. if (find_etaav) then !$OMP do @@ -5247,6 +5270,8 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(vardesc) :: vd(3) character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: am2, ak1 !< Bandwidth parameters of the M2 and K1 streaming filters [nondim] + real :: om2, ok1 !< Target frequencies of the M2 and K1 streaming filters [T-1 ~> s-1] isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -5259,6 +5284,33 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) "sum(u dh_dt) while also correcting for truncation errors.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "STREAMING_FILTER_M2", CS%use_filter_m2, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "STREAMING_FILTER_K1", CS%use_filter_k1, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "FILTER_ALPHA_M2", am2, & + "Bandwidth parameter of the streaming filter targeting the M2 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_M2 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_m2) + call get_param(param_file, mdl, "FILTER_ALPHA_K1", ak1, & + "Bandwidth parameter of the streaming filter targeting the K1 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_K1 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_k1) + call get_param(param_file, mdl, "TIDE_M2_FREQ", om2, & + "Frequency of the M2 tidal constituent. "//& + "This is only used if TIDES and TIDE_M2"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and M2"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("M2"), & + scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "TIDE_K1_FREQ", ok1, & + "Frequency of the K1 tidal constituent. "//& + "This is only used if TIDES and TIDE_K1"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and K1"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("K1"), & + scale=US%T_to_s, do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 if (CS%gradual_BT_ICs) then @@ -5287,6 +5339,24 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) + ! Initialize and register streaming filters + if (CS%use_filter_m2) then + if (am2 > 0.0 .and. om2 > 0.0) then + call Filt_register(am2, om2, 'u', HI, CS%Filt_CS_um2) + call Filt_register(am2, om2, 'v', HI, CS%Filt_CS_vm2) + else + CS%use_filter_m2 = .false. + endif + endif + if (CS%use_filter_k1) then + if (ak1 > 0.0 .and. ok1 > 0.0) then + call Filt_register(ak1, ok1, 'u', HI, CS%Filt_CS_uk1) + call Filt_register(ak1, ok1, 'v', HI, CS%Filt_CS_vk1) + else + CS%use_filter_k1 = .false. + endif + endif + end subroutine register_barotropic_restarts !> \namespace mom_barotropic diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90 new file mode 100644 index 0000000000..a91f6661f2 --- /dev/null +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -0,0 +1,119 @@ +!> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation +module MOM_streaming_filter + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public Filt_register, Filt_accum + +#include + +!> The control structure for storing the filter infomation of a particular field +type, public :: Filter_CS ; private + real :: a, & !< Parameter that determines the bandwidth [nondim] + om, & !< Target frequency of the filter [T-1 ~> s-1] + old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable, dimension(:,:) :: s1, & !< Dummy variable [A] + u1 !< Filtered data [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type Filter_CS + +contains + +!> This subroutine registers each of the fields to be filtered. +subroutine Filt_register(a, om, grid, HI, CS) + real, intent(in) :: a !< Parameter that determines the bandwidth [nondim] + real, intent(in) :: om !< Target frequency of the filter [T-1 ~> s-1] + character(len=*), intent(in) :: grid !< Horizontal grid location: h, u, or v + type(hor_index_type), intent(in) :: HI !< Horizontal index type structure + type(Filter_CS), intent(out) :: CS !< Control structure for the current field + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + if (a <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: bandwidth <= 0") + if (om <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: target frequency <= 0") + + CS%a = a + CS%om = om + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + select case (trim(grid)) + case ('h') + allocate(CS%s1(isd:ied,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = jsd ; CS%je = jed + case ('u') + allocate(CS%s1(IsdB:IedB,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(IsdB:IedB,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = IsdB ; CS%ie = IedB ; CS%js = jsd ; CS%je = jed + case ('v') + allocate(CS%s1(isd:ied,JsdB:JedB)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,JsdB:JedB)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = JsdB ; CS%je = JedB + case default + call MOM_error(FATAL, "MOM_streaming_filter: horizontal grid not supported") + end select + +end subroutine Filt_register + +!> This subroutine timesteps the filter equations. It takes model output u at the current time step as the input, +!! and returns tidal signal u1 as the output, which is the solution of a set of two ODEs (the filter equations). +subroutine Filt_accum(u, u1, Time, US, CS) + real, dimension(:,:), pointer, intent(out) :: u1 !< Output of the filter [A] + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Filter_CS), target, intent(inout) :: CS !< Control structure of the MOM_streaming_filter module + real, dimension(CS%is:CS%ie,CS%js:CS%je), intent(in) :: u !< Input into the filter [A] + + ! Local variables + real :: now, & !< The current model time [T ~> s] + dt, & !< Time step size for the filter equations [T ~> s] + c1, c2 !< Coefficients for the filter equations [nondim] + integer :: i, j, is, ie, js, je + + now = US%s_to_T * time_type_to_real(Time) + is = CS%is ; ie = CS%ie ; js = CS%js ; je = CS%je + + ! Initialize u1 + if (CS%old_time < 0.0) then + CS%old_time = now + CS%u1(:,:) = u(:,:) + endif + + dt = now - CS%old_time + CS%old_time = now + + ! Timestepping + c1 = CS%om * dt + c2 = 1.0 - CS%a * c1 + + do j=js,je ; do i=is,ie + CS%s1(i,j) = c1 * CS%u1(i,j) + CS%s1(i,j) + CS%u1(i,j) = -c1 * (CS%s1(i,j) - CS%a * u(i,j)) + c2 * CS%u1(i,j) + enddo; enddo + u1 => CS%u1 + +end subroutine Filt_accum + +!> \namespace streaming_filter +!! +!! This module detects instantaneous tidal signals in the model output using a set of coupled ODEs (the filter +!! equations), given the target frequency (om) and the bandwidth parameter (a) of the filter. At each timestep, +!! the filter takes model output (u) as the input and returns a time series consisting of sinusoidal motions (u1) +!! near its target frequency. The filtered tidal signals can be used to parameterize frequency-dependent drag, or +!! to detide the model output. See Xu & Zaron (2024) for detail. +!! +!! Reference: Xu, C., & Zaron, E. D. (2024). Detecting instantaneous tidal signals in ocean models utilizing +!! streaming band-pass filters. Journal of Advances in Modeling Earth Systems. Under review. + +end module MOM_streaming_filter + From ffff6f3308f7c1aa9cf6a073eefff40e59ece57d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 29 Jul 2024 04:33:44 -0400 Subject: [PATCH 082/128] +Optionally use SSH in calculate density for PGF Added the option of including the atmospheric or ice pressure and sea surface height displacements from the global reference height in the pressures used in the density calculations for Boussinesq pressure gradient calculations. Note that the full pressures were already being used everywhere apart from the calculation of the equation of state. This capability is controlled by the new runtime parameter SSH_IN_EOS_PRESSURE_FOR_PGF. This commit changes the Z_0p argument to int_density_dz and 8 other routines (int_density_dz_generic_pcm, int_density_dz_generic_plm, int_density_dz_generic_ppm, analytic_int_density_dz, int_density_dz_wright, int_density_dz_wright_full, int_density_dz_wright_red and int_density_dz_linear) from scalars into 2-d arrays, as were the internal z0pres arrays in most of these routines. By default, all answers are bitwise identical, but there is a new runtime parameter in the MOM_parameter_doc files for Boussinesq cases. --- src/core/MOM_PressureForce_FV.F90 | 32 ++++++++- src/core/MOM_density_integrals.F90 | 66 +++++++++++++------ src/equation_of_state/MOM_EOS.F90 | 3 +- src/equation_of_state/MOM_EOS_Wright.F90 | 21 ++++-- src/equation_of_state/MOM_EOS_Wright_full.F90 | 21 ++++-- src/equation_of_state/MOM_EOS_Wright_red.F90 | 22 +++++-- 6 files changed, 124 insertions(+), 41 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 9c4f355692..7b970f5686 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -63,6 +63,9 @@ module MOM_PressureForce_FV !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method + logical :: use_SSH_in_Z0p !< If true, adjust the height at which the pressure used in the + !! equation of state is 0 to account for the displacement of the sea + !! surface including adjustments for atmospheric or sea-ice pressure. logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier @@ -522,6 +525,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. + Z_0p, & ! The height at which the pressure used in the equation of state is 0 [Z ~> m] SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. @@ -577,6 +581,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: I_g_rho ! The inverse of the density times the gravitational acceleration [Z T2 L-2 R-1 ~> m Pa-1] real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure @@ -753,6 +758,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif + if (CS%use_SSH_in_Z0p .and. use_p_atm) then + I_g_rho = 1.0 / (CS%rho0*GV%g_Earth) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho + enddo ; enddo + elseif (CS%use_SSH_in_Z0p) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = G%Z_ref + enddo ; enddo + endif + do k=1,nz ! Calculate 4 integrals through the layer that are required in the ! subsequent calculation. @@ -769,19 +789,19 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & MassWghtInterp=CS%MassWghtInterp, & - use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=Z_0p) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & - MassWghtInterp=CS%MassWghtInterp, Z_0p=G%Z_ref) + MassWghtInterp=CS%MassWghtInterp, Z_0p=Z_0p) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & - CS%MassWghtInterp, Z_0p=G%Z_ref) + CS%MassWghtInterp, Z_0p=Z_0p) endif if (GV%Z_to_H /= 1.0) then !$OMP parallel do default(shared) @@ -1042,6 +1062,12 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) + call get_param(param_file, mdl, "SSH_IN_EOS_PRESSURE_FOR_PGF", CS%use_SSH_in_Z0p, & + "If true, include contributions from the sea surface height in the height-based "//& + "pressure used in the equation of state calculations for the Boussinesq pressure "//& + "gradient forces, including adjustments for atmospheric or sea-ice pressure.", & + default=.false., do_not_log=.not.GV%Boussinesq) + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8d30ba28e3..03d5b6131c 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -80,7 +80,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & @@ -139,7 +140,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] @@ -157,7 +159,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: dz ! The layer thickness [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A pressure-thickness below topography [Z ~> m] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] @@ -184,7 +186,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif use_rho_ref = .true. if (present(use_inaccurate_form)) then if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form @@ -209,7 +217,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dz = z_t(i,j) - z_b(i,j) do n=1,5 T5(i*5+n) = T(i,j) ; S5(i*5+n) = S(i,j) - p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres(i,j)) - 0.25*real(n-1)*dz) enddo enddo @@ -260,7 +268,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - z0pres) + p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j))) ) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) @@ -326,7 +335,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - z0pres) + p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1))) ) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) @@ -414,7 +424,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -464,7 +475,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] @@ -480,7 +491,13 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif massWeightToggle = 0. if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif use_rho_ref = .true. @@ -517,7 +534,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & do i = Isq,Ieq+1 dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) @@ -610,7 +627,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) ! Pressure do n=2,5 @@ -706,7 +724,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) ! Pressure do n=2,5 @@ -812,7 +831,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & !! divided by the y grid spacing [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -864,7 +884,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: t6 ! PPM curvature coefficient for T [C ~> degC] real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T [C ~> degC] real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] @@ -879,7 +899,13 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif massWeightToggle = 0. if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif @@ -924,7 +950,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & endif dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) + p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz) ! Salinity and temperature points are reconstructed with PPM S5(I*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(I*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) @@ -1011,7 +1037,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_x(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i+1,j,K) - e(i+1,j,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) enddo @@ -1116,7 +1143,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_y(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i,j+1,K) - e(i,j+1,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) enddo diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index a66b53656c..74f540f64f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1345,7 +1345,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index f1893ae80f..6fbff16f11 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -435,12 +435,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -466,7 +468,6 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -504,7 +505,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -541,7 +548,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -585,7 +592,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -626,7 +634,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 576f390c70..1f03c1f4aa 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -441,12 +441,14 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -472,7 +474,6 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -510,7 +511,13 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -547,7 +554,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -590,7 +597,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -631,7 +639,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 58a9e2bce1..d46707e911 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -443,12 +443,14 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -474,7 +476,6 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -512,7 +513,13 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -549,7 +556,7 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -592,7 +599,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -633,7 +641,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) From 9b9c165500e2742741a82a52fd69762647ea5303 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Sep 2024 13:53:55 -0400 Subject: [PATCH 083/128] (*)Refactor p_ave calculation Rearranged the calculation of the layer average pressure used in the density integrals to have one less multiply and be clearer to read. This could change answers at roundoff if REFERENCE_HEIGHT is nonzero (it is 0 by default and in all known cases) or if SSH_IN_EOS_PRESSURE_FOR_PGF is set to true. Because the former is mostly used for approximate self-consistency testing and the latter option has just been added, it is unlikely that answers will change for any production runs. --- src/core/MOM_density_integrals.F90 | 18 ++++++------------ src/equation_of_state/MOM_EOS_Wright.F90 | 8 ++++---- src/equation_of_state/MOM_EOS_Wright_full.F90 | 8 ++++---- src/equation_of_state/MOM_EOS_Wright_red.F90 | 9 ++++----- 4 files changed, 18 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 03d5b6131c..8b820594aa 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -268,8 +268,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) - p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i+1,j)-z0pres(i+1,j)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) @@ -335,8 +334,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) - p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i,j+1)-z0pres(i,j+1)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) @@ -627,8 +625,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) ! Pressure do n=2,5 @@ -724,8 +721,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) ! Pressure do n=2,5 @@ -1037,8 +1033,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_x(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i+1,j,K) - e(i+1,j,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) enddo @@ -1143,8 +1138,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & dz_y(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i,j+1,K) - e(i,j+1,K+1))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) enddo diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 6fbff16f11..11fa57644d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -592,8 +592,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -634,8 +634,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 1f03c1f4aa..6dba8444dd 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -597,8 +597,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -639,8 +639,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index d46707e911..87d6a16dba 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -599,8 +599,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -641,9 +641,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) - + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) From 5fc90ebcf25ce99693e4805f64978c18c69d36d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 17 Aug 2024 06:58:47 -0400 Subject: [PATCH 084/128] Rotate ice shelf forcing and initialization Added the ability to rotate the ice shelf forcing and initialization. The specific changes include correcting the grid passed to a call to initialize_ice_shelf in initialize_MOM, using a temporary mech_forcing type in add_shelf_forces when the grid is rotated, uncommenting and correcting the draft rotate_index code in initialize_ice_shelf, and correcting some error-checking and the grid passed to add_shelf_fluxes in initialize_ice_shelf_forces. In addition, unused hor_index_type elements were removed from the ice_shelf_CS, and some callTree calls were added to save_MOM_restart and initialize_ice_shelf. Without rotation, all answers are bitwise identical, but some cases that would have failed previously will now work. --- src/core/MOM.F90 | 11 ++- src/ice_shelf/MOM_ice_shelf.F90 | 158 +++++++++++++++++--------------- 2 files changed, 92 insertions(+), 77 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2f5ac6e489..47971029cc 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2955,20 +2955,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, & Time_init, dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) - call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) + call ice_shelf_query(ice_shelf_CSp, G, CS%frac_shelf_h, CS%mass_shelf) ! MOM_initialize_state is using the unrotated metric call rotate_array(CS%frac_shelf_h, -turns, frac_shelf_in) call rotate_array(CS%mass_shelf, -turns, mass_shelf_in) call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in, & - frac_shelf_h=frac_shelf_in, mass_shelf = mass_shelf_in) + frac_shelf_h=frac_shelf_in, mass_shelf=mass_shelf_in) else call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & @@ -4173,9 +4173,14 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & logical, optional, intent(in) :: write_IC !< If present and true, initial conditions are being written + logical :: showCallTree + showCallTree = callTree_showQuery() + + if (showCallTree) call callTree_waypoint("About to call save_restart (step_MOM)") call save_restart(directory, time, G, CS%restart_CS, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (step_MOM)") if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index eb021d8ffb..4f811cac87 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -24,6 +24,8 @@ module MOM_ice_shelf use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_grid_initialize, only : set_grid_metrics @@ -39,12 +41,12 @@ module MOM_ice_shelf use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_transcribe_grid, only : rotate_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum -use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, deallocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain @@ -59,7 +61,6 @@ module MOM_ice_shelf use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use MOM_coms, only : reproducing_sum use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init @@ -90,10 +91,6 @@ module MOM_ice_shelf type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric - type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. - type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model @@ -1020,18 +1017,18 @@ end subroutine change_thickness_using_melt !> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on !! the ice state in ice_shelf_CS. -subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) +subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external_call) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(mech_forcing), intent(inout) :: forces !< A structure with the + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the !! driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. logical, optional, intent(in) :: external_call !< If true the incoming forcing type - !! is using the input grid metric and needs + !! is using the unrotated input grid and may need !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. -! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces + type(mech_forcing), pointer :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -1041,29 +1038,25 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - if (present(external_call)) rotate=external_call - - if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + rotate = .false. ; if (present(external_call)) rotate = external_call if (CS%rotate_index .and. rotate) then - call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") - ! allocate(forces) - ! call allocate_mech_forcing(forces_in, CS%Grid, forces) - ! call rotate_mech_forcing(forces_in, CS%turns, forces) - ! else - ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & - ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & - ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") - - ! forces=>forces_in + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and external Ice shelf grids.") + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and internal Ice shelf grids.") + + forces=>forces_in endif G=>CS%Grid - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -1125,10 +1118,10 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca scalar_pair=.true.) endif - ! if (CS%rotate_index .and. rotate) then - ! call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! ! TODO: deallocate mech forcing? - ! endif + if (CS%rotate_index .and. rotate) then + call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine add_shelf_forces @@ -1411,6 +1404,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() + type(dyn_horgrid_type), pointer :: dG_in => NULL() real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. @@ -1422,6 +1416,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) + logical :: showCallTree logical :: read_TideAmp, debug logical :: global_indexing character(len=240) :: Tideamp_file ! Input file names @@ -1463,55 +1458,57 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, ! Set up the ice-shelf domain and grid wd_halos(:)=0 - allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + allocate(CS%Grid_in) + call MOM_domains_init(CS%Grid_in%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in', US=CS%US) !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) - call MOM_grid_init(CS%Grid, param_file, CS%US) + call MOM_grid_init(CS%Grid_in, param_file, CS%US) - ! if (CS%rotate_index) then + if (CS%rotate_index) then ! ! TODO: Index rotation currently only works when index rotation does not ! ! change the MPI rank of each domain. Resolving this will require a ! ! modification to FMS PE assignment. ! ! For now, we only permit single-core runs. - ! if (num_PEs() /= 1) & - ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") - - ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & - ! "Number of counterclockwise quarter-turn index rotations.", & - ! default=1, debuggingParam=.true.) - ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. - ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. - ! allocate(CS%Grid) - ! !allocate(CS%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) - ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) - ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) - ! call create_dyn_horgrid(dG, CS%Grid%HI) - ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) - ! ! Set up the bottom depth, G%D either analytically or from file - ! call set_grid_metrics(dG_in,param_file,CS%US) - ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) - ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) - ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) - ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - ! else - !CS%Grid=>CS%Grid_in - dG => NULL() - !CS%Grid%HI=>CS%Grid_in%HI - call create_dyn_horgrid(dG, CS%Grid%HI) - call clone_MOM_domain(CS%Grid%Domain,dG%Domain) - call set_grid_metrics(dG,param_file,CS%US) - ! Set up the bottom depth, dG%bathyT, either analytically or from file - call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) - call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) - call destroy_dyn_horgrid(dG) -! endif - G => CS%Grid ; CS%Grid_in => CS%Grid + if (num_PEs() /= 1) call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) + ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + call set_grid_metrics(dG_in, param_file, CS%US) + ! Set up the bottom depth, dG_in%bathyT, either analytically or from file + call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG_in, CS%Grid_in, CS%US) + + ! Now set up the rotated ice-shelf grid. + allocate(CS%Grid) + call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain, turns=CS%turns) + call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + call MOM_grid_init(CS%Grid, param_file, CS%US, CS%Grid%HI) + call create_dyn_horgrid(dG, CS%Grid%HI) + call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + + call destroy_dyn_horgrid(dG_in) + call destroy_dyn_horgrid(dG) + else + CS%Grid => CS%Grid_in + dG => NULL() + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain) + call set_grid_metrics(dG, param_file, CS%US) + ! Set up the bottom depth, dG%bathyT, either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + call destroy_dyn_horgrid(dG) + endif + G => CS%Grid allocate(CS%diag) call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf') @@ -1979,8 +1976,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_waypoint("About to call save_restart (MOM_ice_shelf)") call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & filename=IC_file, write_ic=.true.) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (MOM_ice_shelf)") endif CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & @@ -2130,16 +2130,23 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) end subroutine initialize_ice_shelf_fluxes +!> Allocate and initialize the ice-shelf forcing elements of a mechanical forcing type. +!! This forcing type is on the unrotated grid that is used outside of the MOM6 ice shelf code. subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces ! Local variables type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") + + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"initialize_ice_shelf_forces: Incompatible ocean and external ice shelf grids.") + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) @@ -2149,10 +2156,13 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) forces=>forces_in endif - call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + call add_shelf_forces(CS%grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet, & + external_call=.false.) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine initialize_ice_shelf_forces From 70a48e3f2b70ebc69780473e42baeda8f3ccecdd Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Mon, 29 Apr 2024 21:00:16 -0700 Subject: [PATCH 085/128] +Add MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP Add MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP option for the top boundary, using top interface height, analogously to what is done near the bathymetry when MASS_WEIGHT_IN_PRESSURE_GRADIENT. The information from the is parameter is encoded in the MassWghtInterp value passed to the various int_density_... and int_spec_vol_... routines, so the routine interfaces do not change. For now this new bit of information about whether to do mass weighting near the surface under ice shelves is only used in int_density_dz_generic_plm. By default this new option is set to false and no answers are changed. --- src/core/MOM_PressureForce_FV.F90 | 15 ++++++++++++--- src/core/MOM_density_integrals.F90 | 31 ++++++++++++++++++++++++++++-- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 7b970f5686..0dfa9d02de 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1028,6 +1028,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, ! temperature variance [nondim] integer :: default_answer_date ! Global answer date logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S + logical :: MassWghtInterpTop ! If true, use near-surface mass weighting for T and S under ice shelves logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1072,9 +1073,14 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in FV pressure gradient "//& - "calculations.", default=.false.) + "If true, use mass weighting when interpolating T/S for integrals "//& + "near the bathymetry in FV pressure gradient calculations.", & + default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP", MassWghtInterpTop, & + "If true and MASS_WEIGHT_IN_PRESSURE_GRADIENT is true, use mass weighting when "//& + "interpolating T/S for integrals near the top of the water column in FV "//& + "pressure gradient calculations. ", & + default=.false.) !### Change Default to MASS_WEIGHT_IN_PRESSURE_GRADIENT? call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_NONBOUS_BUG", MassWghtInterp_NonBous_bug, & "If true, use a masking bug in non-Boussinesq calculations with mass weighting "//& "when interpolating T/S for integrals near the bathymetry in FV pressure "//& @@ -1083,8 +1089,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, CS%MassWghtInterp = 0 if (useMassWghtInterp) & CS%MassWghtInterp = ibset(CS%MassWghtInterp, 0) ! Same as CS%MassWghtInterp + 1 + if (MassWghtInterpTop) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 1) ! Same as CS%MassWghtInterp + 2 if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 + call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8b820594aa..f4bc84306a 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -471,10 +471,12 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! An ice draft limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation @@ -496,8 +498,11 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & else z0pres(:,:) = 0.0 endif - massWeightToggle = 0. - if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. + endif use_rho_ref = .true. if (present(use_inaccurate_form)) use_rho_ref = .not. use_inaccurate_form @@ -592,6 +597,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(i+1,k+1) 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff @@ -688,6 +704,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(j+1,k+1) 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff From 8520c9f5d2b8e0ac37ffb56bbd67e8c548b4abd1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jul 2024 13:48:54 -0400 Subject: [PATCH 086/128] +Add top mass_weight_in_PGF option to 13 integrals Implemented the MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP related capabilities to the 13 density or specific volume integral routines that did not have them yet, mirroring what was already done in int_density_dz_generic_plm. This includes both the density integral routines that are used primarily for Boussinesq cases and the specific volume integral routines that are primarily used with non-Boussinesq simulations. This change includes the addition of an optional SSH argument to int_density_dz and 6 other related routines (int_density_dz_generic_pcm, analytic_int_density_dz, int_density_dz_wright, int_density_dz_wright_full, int_density_dz_wright_red and int_density_dz_linear). It also includes the addition of an optional P_surf argument to int_specific_vol_dp and 7 other related routines (int_spec_vol_dp_generic_pcm, int_spec_vol_dp_generic_plm, analytic_int_specific_vol_dp int_spec_vol_dp_wright, int_spec_vol_dp_wright_full, int_spec_vol_dp_wright_red and int_spec_vol_dp_linear). Both of these new optional arguments are required when the new near-surface mass weighting is activated, and there are test that would issue a fatal error if they are not provided in such cases. (Note that these routines can be called from other places than the pressure gradient force calculation, in which case the calculations that need these fields are not done.) The diagnose_mass_weight_Z and diagnose_mass_weight_p diagnostic routines were similarly revised to mirror the expanded range of capabilities in the integral routines. This commit can change answers when MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP is true, but all answers are bitwise identical otherwise. There are new arguments to 15 publicly visible routines. --- src/core/MOM_PressureForce_FV.F90 | 16 +- src/core/MOM_density_integrals.F90 | 296 +++++++++++------- src/equation_of_state/MOM_EOS.F90 | 32 +- src/equation_of_state/MOM_EOS_Wright.F90 | 46 +-- src/equation_of_state/MOM_EOS_Wright_full.F90 | 46 +-- src/equation_of_state/MOM_EOS_Wright_red.F90 | 46 +-- src/equation_of_state/MOM_EOS_linear.F90 | 46 +-- 7 files changed, 325 insertions(+), 203 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0dfa9d02de..41e1a85a61 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -277,25 +277,25 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & - MassWghtInterp=CS%MassWghtInterp) + P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & ! alpha_ref, G%HI, tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & - ! intx_dza(:,:,k), inty_dza(:,:,k)) + ! intx_dza(:,:,k), inty_dza(:,:,k), P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) endif else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & - inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & + inty_dza(:,:,k), bathyP=p(:,:,nz+1), P_surf=p(:,:,1), dP_tiny=dp_neglect, & MassWghtInterp=CS%MassWghtInterp) endif if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & - call diagnose_mass_weight_p(p(:,:,K), p(:,:,K+1), dp_neglect, p(:,:,nz+1), G%HI, & - MassWt_u(:,:,k), MassWt_v(:,:,k)) + call diagnose_mass_weight_p(p(:,:,K), p(:,:,K+1), p(:,:,nz+1), p(:,:,1), dp_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k)) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -800,7 +800,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & - intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & + intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, e(:,:,1), dz_neglect, & CS%MassWghtInterp, Z_0p=Z_0p) endif if (GV%Z_to_H /= 1.0) then @@ -810,8 +810,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & - call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), dz_neglect, G%bathyT, G%HI, & - MassWt_u(:,:,k), MassWt_v(:,:,k)) + call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), G%bathyT, e(:,:,1), dz_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k)) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index f4bc84306a..90994dd073 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -40,7 +40,7 @@ module MOM_density_integrals !! required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -77,6 +77,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -85,10 +87,10 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) else call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif end subroutine int_density_dz @@ -97,7 +99,7 @@ end subroutine int_density_dz !> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which !! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, use_inaccurate_form, Z_0p) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. real, dimension(SZI_(HI),SZJ_(HI)), & @@ -135,6 +137,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -169,7 +173,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] - logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -198,13 +203,16 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form endif - do_massWeight = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (do_massWeight) then - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if MassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if MassWghtInterp is present and true.") + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + if (do_massWeight .and. .not.present(bathyT)) call MOM_error(FATAL, & + "int_density_dz_generic: bathyT must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(SSH)) call MOM_error(FATAL, & + "int_density_dz_generic: SSH must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dz_neglect)) call MOM_error(FATAL, & + "int_density_dz_generic: dz_neglect must be present if mass weighting is in use.") endif ! Set the loop ranges for equation of state calculations at various points. @@ -248,6 +256,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -314,6 +324,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -470,8 +482,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] - real :: TopWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] @@ -900,7 +912,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: dz ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [S ~> ppt] real :: s6 ! PPM curvature coefficient for S [S ~> ppt] @@ -909,6 +922,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! A surface displacement limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -929,8 +943,11 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & else z0pres(:,:) = 0.0 endif - massWeightToggle = 0. - if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. + endif ! In event PPM calculation is bypassed with use_PPM=False s6 = 0. @@ -1017,6 +1034,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) + hWght = max(hWght, hWghtTop) if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff @@ -1122,6 +1142,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) + hWght = max(hWght, hWghtTop) if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff @@ -1223,7 +1246,7 @@ end subroutine int_density_dz_generic_ppm !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, MassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1257,6 +1280,8 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -1265,11 +1290,11 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & if (EOS_quadrature(EOS)) then call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, MassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) else call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, MassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) endif end subroutine int_specific_vol_dp @@ -1281,7 +1306,7 @@ end subroutine int_specific_vol_dp !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, MassWghtInterp) + bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [C ~> degC] @@ -1316,6 +1341,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -1352,6 +1379,7 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -1365,14 +1393,17 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set - if (do_massWeight) then - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if MassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if MassWghtInterp is present and true.") + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (do_massWeight .and. .not.present(bathyP)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: bathyP must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: P_surf must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dP_neglect)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: dP_neglect must be present if mass weighting is in use.") endif ! Set the loop ranges for equation of state calculations at various points. @@ -1417,6 +1448,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1475,6 +1508,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1530,7 +1565,7 @@ end subroutine int_spec_vol_dp_generic_pcm !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & dP_neglect, bathyP, HI, EOS, US, dza, & - intp_dza, intx_dza, inty_dza, MassWghtInterp) + intp_dza, intx_dza, inty_dza, P_surf, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the top of the layer [C ~> degC] @@ -1570,6 +1605,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, optional, intent(inout) :: inty_dza !< The integral in y of the difference between !! the geopotential anomaly at the top and bottom of the layer divided !! by the y grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -1608,6 +1645,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state @@ -1616,9 +1654,14 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_plm: P_surf must be present if near-surface mass weighting is in use.") + endif do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) @@ -1666,6 +1709,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -1730,6 +1775,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -1787,71 +1834,87 @@ end subroutine int_spec_vol_dp_generic_plm !> Diagnose the fractional mass weighting in a layer that might be used with a Boussinesq calculation. -subroutine diagnose_mass_weight_Z(z_t, z_b, dz_neglect, bathyT, HI, MassWt_u, MassWt_v) +subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: SSH !< The sea surface height [Z ~> m] + real, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, dimension(SZIB_(HI),SZJ_(HI)), & - optional, intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] real, dimension(SZI_(HI),SZJB_(HI)), & - optional, intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] ! Local variables real :: hWght ! A pressure-thickness below topography [Z ~> m] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface integer :: Isq, Ieq, Jsq, Jeq, i, j Isq = HI%IscB ; Ieq = HI%IecB Jsq = HI%JscB ; Jeq = HI%JecB - if (present(MassWt_u)) then - do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom - else - MassWt_u(I,j) = 0.0 - endif - enddo ; enddo - endif + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo - if (present(MassWt_v)) then - do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom - else - MassWt_v(i,J) = 0.0 - endif - enddo ; enddo - endif + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo end subroutine diagnose_mass_weight_Z !> Diagnose the fractional mass weighting in a layer that might be used with a non-Boussinesq calculation. -subroutine diagnose_mass_weight_p(p_t, p_b, dP_neglect, bathyP, HI, MassWt_u, MassWt_v) +subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] @@ -1861,55 +1924,78 @@ subroutine diagnose_mass_weight_p(p_t, p_b, dP_neglect, bathyP, HI, MassWt_u, Ma !! the same units as p_t [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, dimension(SZIB_(HI),SZJ_(HI)), & - optional, intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] real, dimension(SZI_(HI),SZJB_(HI)), & - optional, intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] ! Local variables real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting integer :: Isq, Ieq, Jsq, Jeq, i, j Isq = HI%IscB ; Ieq = HI%IecB Jsq = HI%JscB ; Jeq = HI%JecB - if (present(MassWt_u)) then - do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom - else - MassWt_u(I,j) = 0.0 - endif - enddo ; enddo - endif + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_u(I,j) = 0.0 + endif + enddo ; enddo - if (present(MassWt_v)) then - do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom - else - MassWt_v(i,J) = 0.0 - endif - enddo ; enddo - endif + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom + else + MassWt_v(i,J) = 0.0 + endif + enddo ; enddo end subroutine diagnose_mass_weight_p diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 74f540f64f..bfab3f5719 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1226,7 +1226,7 @@ end function EOS_domain !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, MassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1259,6 +1259,8 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -1280,20 +1282,20 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, MassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_FULL) call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case (EOS_WRIGHT_REDUCED) call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, MassWghtInterp, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default @@ -1306,7 +1308,7 @@ end subroutine analytic_int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1342,6 +1344,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -1367,23 +1371,23 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & rho_scale*EOS%Rho_T0_S0, dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) else call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, MassWghtInterp) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) endif case (EOS_WRIGHT) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_FULL) @@ -1391,12 +1395,12 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT_REDUCED) @@ -1404,12 +1408,12 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, rho_scale, pres_scale, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case default diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 11fa57644d..874d3e784e 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -387,7 +387,7 @@ end subroutine EoS_fit_range_buggy_Wright !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -424,6 +424,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -481,6 +483,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -531,14 +534,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - ! if (do_massWeight) then - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if MassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if MassWghtInterp is present and true.") - ! endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) @@ -571,6 +571,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -613,6 +615,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -656,7 +660,7 @@ end subroutine int_density_dz_wright !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -693,6 +697,8 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -743,6 +749,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] @@ -780,15 +787,12 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set -! if (do_massWeight) then -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if MassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if MassWghtInterp is present and true.") -! endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -818,6 +822,8 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -862,6 +868,8 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 6dba8444dd..4be5f2940e 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -393,7 +393,7 @@ end subroutine EoS_fit_range_Wright_full !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -430,6 +430,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -487,6 +489,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -537,14 +540,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - ! if (do_massWeight) then - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if MassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if MassWghtInterp is present and true.") - ! endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -576,6 +576,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -618,6 +620,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -661,7 +665,7 @@ end subroutine int_density_dz_wright_full !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -698,6 +702,8 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -749,6 +755,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] @@ -786,15 +793,12 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set -! if (do_massWeight) then -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if MassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if MassWghtInterp is present and true.") -! endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha = (lambda + al0*(pressure + p0)) / (pressure + p0) do j=jsh,jeh ; do i=ish,ieh @@ -825,6 +829,8 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -870,6 +876,8 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 87d6a16dba..1635f9e809 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -395,7 +395,7 @@ end subroutine EoS_fit_range_Wright_red !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -432,6 +432,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -489,6 +491,7 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -539,14 +542,11 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - ! if (do_massWeight) then - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if MassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if MassWghtInterp is present and true.") - ! endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) @@ -578,6 +578,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -620,6 +622,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -663,7 +667,7 @@ end subroutine int_density_dz_wright_red !! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) !! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -700,6 +704,8 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -751,6 +757,7 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] @@ -788,15 +795,12 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set -! if (do_massWeight) then -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if MassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if MassWghtInterp is present and true.") -! endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh @@ -827,6 +831,8 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -872,6 +878,8 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index f5673ba5f2..e443970535 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -258,7 +258,7 @@ end subroutine set_params_linear !! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, MassWghtInterp) + bathyT, SSH, dz_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -299,6 +299,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals @@ -317,6 +319,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real :: intz(5) ! The integrals of density with height at the ! 5 sub-column locations [R L2 T-2 ~> Pa] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m @@ -327,14 +330,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & is = HI%isc ; ie = HI%iec js = HI%jsc ; je = HI%jec - do_massWeight = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - ! if (do_massWeight) then - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if MassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if MassWghtInterp is present and true.") - ! endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) @@ -350,6 +350,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) @@ -389,6 +391,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) @@ -429,7 +433,7 @@ end subroutine int_density_dz_linear !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, MassWghtInterp) + bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -469,6 +473,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use @@ -488,6 +494,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -498,15 +505,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif - do_massWeight = .false. ; massWeight_bug = .false. - if (present(MassWghtInterp)) do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values - if (present(MassWghtInterp)) massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set -! if (do_massWeight) then -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if MassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if MassWghtInterp is present and true.") -! endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) @@ -527,6 +531,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & elseif (do_massWeight) then hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) @@ -575,6 +581,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & elseif (do_massWeight) then hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) From e172fe81843c0b51d90f6f6bb09ca27241ba4085 Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Mon, 29 Apr 2024 21:29:52 -0700 Subject: [PATCH 087/128] +Add CORRECTION_INTXPA Add CORRECTION_INTXPA which makes a quadratic correction to surface pressure integrals (intx_pa and inty_pa) under ice based on the horizontal gradients of the in-situ density anomaly along the surface. The non-Boussinesq version corrects the topmost value of intx_za and inty_za and uses in-situ specific volume gradients along the ocean surface. By default new the runtime parameter CORRECTION_INTXPA is false, and answers are unchanged. --- src/core/MOM_PressureForce_FV.F90 | 190 +++++++++++++++++++++++++----- 1 file changed, 161 insertions(+), 29 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 41e1a85a61..0913c54ebd 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -15,7 +15,7 @@ module MOM_PressureForce_FV use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_density_integrals, only : int_spec_vol_dp_generic_plm @@ -48,6 +48,7 @@ module MOM_PressureForce_FV type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation + logical :: correction_intxpa !< If true, apply a correction to surface intxpa under ice. logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -152,12 +153,19 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + SpV_top ! Specific volume anomaly of top layer used with correction_intxpa [R-1 ~> m3 kg-1] + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_za_cor ! Correction for curvature in intx_za [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_za_cor ! Correction for curvature in inty_za [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & MassWt_u ! The fractional mass weighting at a u-point [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & MassWt_v ! The fractional mass weighting at a v-point [nondim]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: dp_sfc ! The change in surface pressure between adjacent cells [R L2 T-2 ~> Pa] real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. @@ -178,6 +186,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. ! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] real, parameter :: C1_6 = 1.0/6.0 ! [nondim] + real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k @@ -375,28 +384,76 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo - ! This order of integrating upward and then downward again is necessary with - ! a nonlinear equation of state, so that the surface geopotentials will go - ! linearly between the values at thickness points, but the bottom geopotentials - ! will not now be linear at the sub-grid-scale. Doing this ensures no motion - ! with flat isopycnals, even with a nonlinear equation of state. ! With an ice-shelf or icebergs, this linearity condition might need to be applied ! to a sub-surface interface. - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) - enddo ; enddo + if (CS%correction_intxpa) then + ! Determine surface specific volume for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then + do j=Jsq,Jeq+1 + call calculate_spec_vol(tv%T(:,j,1), tv%S(:,j,1), p(:,j,1), SpV_top(:,j), & + tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) + enddo + elseif (use_EOS) then + do j=Jsq,Jeq+1 + call calculate_spec_vol(tv%T(:,j,1), tv%S(:,j,1), p(:,j,1), SpV_top(:,j), & + tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) + enddo + else + alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SpV_top(i,j) = alpha_anom + enddo ; enddo + endif + + ! This version attempts to correct for hydrostatic variations in surface pressure under ice. + !$OMP parallel do default(shared) private(dp_sfc) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + ! In non-Bousinesq mode, no other restrictions seem to be needed, and even the test + ! above might be unnecessary, but a test for the implied specific volume being at least + ! half the average specific volume would be: + ! if ((alpha_ref - dza / dp) > 0.25*((SpV_top(i+1,j)+SpV_top(i,j)) + 2.0*alpha_ref)) & + intx_za_cor(I,j) = C1_12 * (SpV_top(i+1,j)-SpV_top(i,j)) * dp_sfc + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + inty_za_cor(i,J) = C1_12 * (SpV_top(i,j+1)-SpV_top(i,j)) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo + else + ! This order of integrating upward and then downward again is necessary with + ! a nonlinear equation of state, so that the surface geopotentials will go + ! linearly between the values at thickness points, but the bottom geopotentials + ! will not now be linear at the sub-grid-scale. Doing this ensures no motion + ! with flat isopycnals, even with a nonlinear equation of state. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + enddo ; enddo + endif + do k=1,nz !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq intx_za(I,j,K+1) = intx_za(I,j,K) - intx_dza(I,j,k) enddo ; enddo enddo - - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) - enddo ; enddo do k=1,nz !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie @@ -552,6 +609,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_pa_cor ! Correction for curvature in intx_pa [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_pa_cor ! Correction for curvature in inty_pa [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -567,6 +628,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm MassWt_u ! The fractional mass weighting at a u-point [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & MassWt_v ! The fractional mass weighting at a v-point [nondim]. + real, dimension(SZI_(G),SZJ_(G)) :: & + rho_top ! Density anomaly of top layer used in calculating intx_pa_cor and inty_pa_cor real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance ! in Stanley parameterization. @@ -576,7 +639,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: p_surf_EOS(SZI_(G)) ! The pressure at the ocean surface determined from the surface height, + ! consistent with what is used in the density integral routines [R L2 T-2 ~> Pa] real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. + real :: dz_geo_sfc ! The change in surface geopotential height between adjacent cells [L2 T-2 ~> m2 s-2] + real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> Pa m-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. @@ -590,11 +657,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real, parameter :: C1_6 = 1.0/6.0 ! [nondim] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k + real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] + real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies @@ -838,25 +906,86 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo enddo - ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, - ! assuming that the surface pressure anomaly varies linearly in x and y. - ! If there is an ice-shelf or icebergs, this linear variation would need to be applied - ! to an interior interface. - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) - enddo ; enddo + if (CS%correction_intxpa) then + + ! Determine surface density for use in the pressure gradient corrections + GxRho = GV%g_Earth * CS%rho0 + if (use_ALE .and. CS%Recon_Scheme > 0) then + !$OMP parallel do default(shared) private(p_surf_EOS) + do j=Jsq,Jeq+1 + ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - G%Z_ref) ; enddo + call calculate_density(T_t(:,j,1), S_t(:,j,1), p_surf_EOS, rho_top(:,j), & + tv%eqn_of_state, EOSdom, rho_ref=rho_ref) + enddo + elseif (use_EOS) then + !$OMP parallel do default(shared) private(p_surf_EOS) + do j=Jsq,Jeq+1 + ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - G%Z_ref) ; enddo + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_surf_EOS, rho_top(:,j), & + tv%eqn_of_state, EOSdom, rho_ref=rho_ref) + enddo + else ! T and S are not state variables. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + rho_top(i,j) = GV%Rlay(1) - rho_ref + enddo ; enddo + endif + + ! This version attempts to correct for hydrostatic variations in surface pressure under ice. + !$OMP parallel do default(shared) private(dz_geo_sfc) + do j=js,je ; do I=Isq,Ieq + intx_pa_cor(I,j) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + if (dz_geo_sfc * (rho_ref - (pa(i+1,j,1)-pa(i,j,1))*dz_geo_sfc) > 0.0) then + ! The pressure/depth relationship has a positive implied density given by + ! rho_implied = rho_ref - (pa(i+1,j,1)-pa(i,j,1)) / dz_geo_sfc + if (-dz_geo_sfc * (pa(i+1,j,1)-pa(i,j,1)) > & + 0.25*((rho_top(i+1,j)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc + endif + endif + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dz_geo_sfc) + do J=Jsq,Jeq ; do i=is,ie + inty_pa_cor(i,J) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + if (dz_geo_sfc * (rho_ref - (pa(i,j+1,1)-pa(i,j,1))*dz_geo_sfc) > 0.0) then + ! The pressure/depth relationship has a positive implied density + if (-dz_geo_sfc * (pa(i,j+1,1)-pa(i,j,1)) > & + 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc + endif + endif + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) + enddo ; enddo + else + ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, + ! assuming that the surface pressure anomaly varies linearly in x and y. + ! If there is an ice-shelf or icebergs, this linear variation would need to be applied + ! to an interior interface. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + enddo ; enddo + endif + do k=1,nz !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k) enddo ; enddo enddo - - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) - enddo ; enddo do k=1,nz !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie @@ -1094,6 +1223,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 + call get_param(param_file, mdl, "CORRECTION_INTXPA",CS%correction_intxpa, & + "If true, use a correction for surface pressure curvature in intx_pa.", & + default = .false.) call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) From 15ea6282b131c02030b75deecd8cbbeebdbd9581 Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Mon, 29 Apr 2024 22:03:37 -0700 Subject: [PATCH 088/128] +Add CORRECTION_INTXPA_5PT Add CORRECTION_INTXPA_5PT which uses 5 point quadrature to calculate surface pressure integral and therefore could work with a nonlinear EOS, or (if added) different subgrid distributions. This option requires CORRECTION_INTXPA = True. By default CORRECTION_INTXPA_5PT is false and no answers are changed. --- src/core/MOM_PressureForce_FV.F90 | 75 +++++++++++++++++++++++++++++-- 1 file changed, 72 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0913c54ebd..a35c2d2a90 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -49,6 +49,7 @@ module MOM_PressureForce_FV !! timing of diagnostic output. integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation logical :: correction_intxpa !< If true, apply a correction to surface intxpa under ice. + logical :: correction_intxpa_5pt ! Use 5 point quadrature to calculate surface intxpa logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -660,9 +661,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: i, j, k + integer :: i, j, k, m + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] + real :: wt_R ! A weighting factor [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies @@ -945,7 +951,37 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 0.25*((rho_top(i+1,j)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. - intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc + if (CS%correction_intxpa_5pt) then + !! Use 5 point quadrature to calculate intxpa + T5(1) = T_t(I,j,1) ; T5(5) = T_t(I+1,j,1) + S5(1) = S_t(I,j,1) ; S5(5) = S_t(I+1,j,1) + ! Pressure input to density EOS should be real pressure not rho_ref, I think + p5(1) = pa(I,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p5(5) = pa(I+1,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1)+(T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); + S5(m) = S5(1)+(S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + p5(m) = p5(1)+(p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + ! add rhoref back in + do m=1,5 + p5(m) = p5(m) + (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + enddo + do m=2,4 + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! Do this by integrating pressure between each of the 5 points and adding up + ! This way integration direction doesn't matter when adding up pressure from previous point + p5(m) = p5(m-1) + ((0.25*(p5(5)-p5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & + 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) + enddo + intx_pa(I,j,1) = C1_90*(7.0*(p5(1)+p5(5)) + 32.0*(p5(2)+p5(4)) + 12.0*p5(3)) + ! Get correction from difference between this and linear average. This is clunky and repetitive. + intx_pa_cor(I,j) = -0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa(I,j,1) + else ! Do not use 5-point quadrature. + intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc + endif endif endif intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa_cor(I,j) @@ -960,7 +996,37 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. - inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc + if (CS%correction_intxpa_5pt) then + !! Use 5 point quadrature to calculate intxpa + T5(1) = T_t(I,j,1) ; T5(5) = T_t(i,j+1,1) + S5(1) = S_t(I,j,1) ; S5(5) = S_t(i,j+1,1) + ! Pressure input to density EOS should be real pressure not rho_ref, I think + p5(1) = pa(i,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p5(5) = pa(i,j+1,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1)+(T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); + S5(m) = S5(1)+(S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + p5(m) = p5(1)+(p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + ! add rhoref back in + do m=1,5 + p5(m) = p5(m) + (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + enddo + do m=2,4 + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! Do this by integrating pressure between each of the 5 points and adding up + ! This way integration direction doesn't matter when adding up pressure from previous point + p5(m) = p5(m-1) + ((0.25*(p5(5)-p5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & + 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) + enddo + inty_pa(I,j,1) = C1_90*(7.0*(p5(1)+p5(5)) + 32.0*(p5(2)+p5(4)) + 12.0*p5(3)) + ! Get correction from difference between this and linear average. This is clunky and repetitive. + inty_pa_cor(I,j) = -0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa(I,j,1) + else ! Do not use 5-point quadrature. + inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc + endif endif endif inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) @@ -1226,6 +1292,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "CORRECTION_INTXPA",CS%correction_intxpa, & "If true, use a correction for surface pressure curvature in intx_pa.", & default = .false.) + call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT",CS%correction_intxpa_5pt, & + "If true, use 5point quadrature to calculate intxpa. This requires "//& + "CORRECTION_INTXPA = True.",default = .false.) call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) From 1b9bf67d4fde4cdf55d81513d60bafc1cd4007d2 Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Mon, 29 Apr 2024 22:21:54 -0700 Subject: [PATCH 089/128] +Add RESET_INTXPA_INTEGRAL Add RESET_INTXPA_INTEGRAL which resets intxpa and intypa at a trusted cell in the interior (non-vanished and non-MWIPG-affected), and then integrates both up and down to update intxpa and intypa for the interfaces above and below. This also adds the new runtime parameter RESET_INTXPA_H_NONVANISHED and to determine when a cell is trusted. This option is recommended with MASS_WEIGHT_IN_PRESSURE_GRADIENT_IS for a quiet zstar ice shelf. By default, this option is not on and no answers change, but there are new parameters in some MOM_parameter_doc files. --- src/core/MOM_PressureForce_FV.F90 | 88 +++++++++++++++++++++++++++---- 1 file changed, 78 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index a35c2d2a90..6a9620eb39 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -49,7 +49,11 @@ module MOM_PressureForce_FV !! timing of diagnostic output. integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation logical :: correction_intxpa !< If true, apply a correction to surface intxpa under ice. - logical :: correction_intxpa_5pt ! Use 5 point quadrature to calculate surface intxpa + logical :: correction_intxpa_5pt !< Use 5 point quadrature to calculate surface intxpa + logical :: reset_intxpa_integral !< In the interior, reset intxpa at a trusted cell (for ice shelf) + real :: h_nonvanished !< A minimal layer thickness that indicates that a layer is thick enough + !! to usefully reestimate the pressure integral across the interface + !! below it [H ~> m or kg m-2] logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -661,7 +665,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: i, j, k, m + integer :: i, j, k, m, k2 real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] @@ -669,6 +673,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] real :: wt_R ! A weighting factor [nondim] + real :: rho_tr, rho_tl ! Store right and left densities in reset intxpa calculation [R ~> kg m-3] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies @@ -952,12 +957,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. if (CS%correction_intxpa_5pt) then - !! Use 5 point quadrature to calculate intxpa + ! Use 5 point quadrature to calculate intxpa T5(1) = T_t(I,j,1) ; T5(5) = T_t(I+1,j,1) S5(1) = S_t(I,j,1) ; S5(5) = S_t(I+1,j,1) - ! Pressure input to density EOS should be real pressure not rho_ref, I think - p5(1) = pa(I,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) - p5(5) = pa(I+1,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. + p5(1) = pa(i,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p5(5) = pa(i+1,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) do m=2,4 wt_R = 0.25*real(m-1) T5(m) = T5(1)+(T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); @@ -996,11 +1001,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. - if (CS%correction_intxpa_5pt) then - !! Use 5 point quadrature to calculate intxpa + if (CS%correction_intxpa_5pt) then + ! Use 5 point quadrature to calculate intypa T5(1) = T_t(I,j,1) ; T5(5) = T_t(i,j+1,1) S5(1) = S_t(I,j,1) ; S5(5) = S_t(i,j+1,1) - ! Pressure input to density EOS should be real pressure not rho_ref, I think + ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. p5(1) = pa(i,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) p5(5) = pa(i,j+1,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) do m=2,4 @@ -1059,6 +1064,62 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo enddo + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intxpa there, then adjust intxpa above and below using the same increments between interfaces as above. + ! Note: This currently assumes pressure varies quadratically along the bottom of the topmost non-vanished, + ! non-mass-weighted layer. Possibly 5 pt quadrature should be implemented as for the surface. + if (CS%reset_intxpa_integral) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + kloop: do k=1,nz-1 + ! Check if both sides are nonvanished and mass-weighting is not activated in the subgrid interpolation. + if ((h(i,j,k)>CS%h_nonvanished) .and. (h(i+1,j,k)>CS%h_nonvanished)) then + if (.not. (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) > 0.0)) then + ! Calculate pressure at the bottom of this cell (pa are known) + ! then we have a "good estimate" for intxpa (it might have quadratic pressure dependence if sloped) + ! now we recalculate intx_pa and PFu at each level working up and then down + call calculate_density(T_t(i,j,k+1), S_t(i,j,k+1), pa(i,j,K+1), rho_tl, & + tv%eqn_of_state, rho_ref=rho_ref) + call calculate_density(T_t(i+1,j,k+1), S_t(i+1,j,k+1), pa(i+1,j,K+1), rho_tr, & + tv%eqn_of_state, rho_ref=rho_ref) + inty_pa_cor(I,j) = C1_12 * (rho_tr-rho_tl)*GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + intx_pa(i,j,K+1) = 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + inty_pa_cor(I,j) + do k2=1,k + intx_pa(I,j,K-K2+1) = intx_pa(I,j,(K-K2+2)) - intx_dpa(i,j,k-k2+1) + enddo + do k2=k+2,nz + intx_pa(I,j,K2) = intx_pa(I,j,K2-1) + intx_dpa(i,j,k2-1) + enddo + exit kloop + endif ; endif + enddo kloop + enddo ; enddo + + do J=Jsq,Jeq+1 ; do i=is,ie+1 + kloop2: do k=1,nz-1 + ! Check if both sides are nonvanished and mass-weighting is not activated in the subgrid interpolation. + if ((h(i,j,k)>CS%h_nonvanished) .and. (h(i,j+1,k)>CS%h_nonvanished)) then + if (.not. (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) > 0.0)) then + ! calculate pressure at the bottom of this cell (pa are known) + ! then we have a "good estimate" for intxpa (it might have quadratic pressure dependence if sloped) + ! now we recalculate intx_pa and PFu at each level working up and then down + call calculate_density(T_t(i,j,k+1), S_t(i,j,k+1), pa(i,j,K+1), rho_tl, & + tv%eqn_of_state, rho_ref=rho_ref) + call calculate_density(T_t(i,j+1,k+1), S_t(i,j+1,k+1), pa(i,j+1,K+1), rho_tr, & + tv%eqn_of_state, rho_ref=rho_ref) + inty_pa_cor(i,J) = C1_12 * (rho_tr-rho_tl) * GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) + inty_pa(i,J,K+1) = 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + inty_pa_cor(i,J) + do k2=1,k + inty_pa(i,J,K-K2+1) = inty_pa(i,J,(K-K2+2)) - inty_dpa(i,J,k-k2+1) + enddo + do k2=k+2,nz + inty_pa(i,J,K2) = inty_pa(i,J,K2-1) + inty_dpa(i,J,k2-1) + enddo + exit kloop2 + endif ; endif + enddo kloop2 + enddo ; enddo + endif ! intx_pa and inty_pa are now reset and should be correct + ! Compute pressure gradient in x direction !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -1292,9 +1353,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "CORRECTION_INTXPA",CS%correction_intxpa, & "If true, use a correction for surface pressure curvature in intx_pa.", & default = .false.) - call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT",CS%correction_intxpa_5pt, & + call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT", CS%correction_intxpa_5pt, & "If true, use 5point quadrature to calculate intxpa. This requires "//& "CORRECTION_INTXPA = True.",default = .false.) + call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & + "If true, reset INTXPA to match pressures at first nonvanished cell. "//& + "Includes pressure correction. ", default = .false.) + call get_param(param_file, mdl, "RESET_INTXPA_H_NONVANISHED", CS%h_nonvanished, & + "A minimal layer thickness that indicates that a layer is thick enough to usefully "//& + "reestimate the pressure integral across the interface below.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=.not.CS%reset_intxpa_integral) call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) From 7a9545aefc2ef73c35a431c9593b93cb34049db3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jul 2024 17:36:17 -0400 Subject: [PATCH 090/128] Revisions of sub-ice pressure gradient fixes Refactored and revised the recently added code in MOM_PressureForce_FV.F90 to reduce the number of calls to the equation of state routines, and corrected a number of minor bugs in the original implementation. Answers are bitwise identical unless the new options to reset the pressure gradient calculations are actively selected. --- src/core/MOM_PressureForce_FV.F90 | 254 +++++++++++++++++++----------- 1 file changed, 165 insertions(+), 89 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 6a9620eb39..04e6ed7b96 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -619,6 +619,37 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, dimension(SZI_(G),SZJB_(G)) :: & inty_pa_cor ! Correction for curvature in inty_pa [R L2 T-2 ~> Pa] + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + rho_x_W, rho_x_E, & ! Density anomalies on the reference interface to the east and west + ! of a u-point [R ~> kg m-3] + intx_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_x, & ! The change in x in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + intx_pa_cor_ri ! The correction to intx_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + rho_y_S, rho_y_N, & ! Density anomalies on the reference interface to the north and south + ! of a v-point [R ~> kg m-3] + inty_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_y, & ! The change in y in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + inty_pa_cor_ri ! The correction to inty_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [C ~> degC]. @@ -661,13 +692,18 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k, m, k2 real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] - real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five + ! quadrature points [R L2 T-2 ~> Pa]. real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] @@ -679,6 +715,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") @@ -693,6 +731,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 + GxRho = GV%g_Earth * GV%Rho0 rho_ref = CS%Rho0 if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then @@ -828,12 +867,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + pa(i,j,1) = GxRho*(e(i,j,1) - G%Z_ref) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + pa(i,j,1) = GxRho*(e(i,j,1) - G%Z_ref) enddo ; enddo endif @@ -920,7 +959,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%correction_intxpa) then ! Determine surface density for use in the pressure gradient corrections - GxRho = GV%g_Earth * CS%rho0 if (use_ALE .and. CS%Recon_Scheme > 0) then !$OMP parallel do default(shared) private(p_surf_EOS) do j=Jsq,Jeq+1 @@ -949,7 +987,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm do j=js,je ; do I=Isq,Ieq intx_pa_cor(I,j) = 0.0 dz_geo_sfc = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) - if (dz_geo_sfc * (rho_ref - (pa(i+1,j,1)-pa(i,j,1))*dz_geo_sfc) > 0.0) then + if ((dz_geo_sfc * rho_ref - (pa(i+1,j,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then ! The pressure/depth relationship has a positive implied density given by ! rho_implied = rho_ref - (pa(i+1,j,1)-pa(i,j,1)) / dz_geo_sfc if (-dz_geo_sfc * (pa(i+1,j,1)-pa(i,j,1)) > & @@ -958,32 +996,28 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. if (CS%correction_intxpa_5pt) then ! Use 5 point quadrature to calculate intxpa - T5(1) = T_t(I,j,1) ; T5(5) = T_t(I+1,j,1) - S5(1) = S_t(I,j,1) ; S5(5) = S_t(I+1,j,1) + T5(1) = T_t(i,j,1) ; T5(5) = T_t(i+1,j,1) + S5(1) = S_t(i,j,1) ; S5(5) = S_t(i+1,j,1) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. - p5(1) = pa(i,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) - p5(5) = pa(i+1,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p5(1) = pa(i,j,1) - GxRho*(e(i,j,1) - G%Z_ref) + p5(5) = pa(i+1,j,1) - GxRho*(e(i+1,j,1) - G%Z_ref) do m=2,4 wt_R = 0.25*real(m-1) - T5(m) = T5(1)+(T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); - S5(m) = S5(1)+(S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); - p5(m) = p5(1)+(p5(5)-p5(1))*wt_R + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R enddo !m call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - ! add rhoref back in - do m=1,5 - p5(m) = p5(m) + (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) - enddo do m=2,4 ! Make pressure curvature a difference from the linear fit of pressure between the two points ! Do this by integrating pressure between each of the 5 points and adding up ! This way integration direction doesn't matter when adding up pressure from previous point - p5(m) = p5(m-1) + ((0.25*(p5(5)-p5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & - 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) + pa5(m) = pa5(m-1) + ((0.25*(pa5(5)-pa5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & + 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) enddo - intx_pa(I,j,1) = C1_90*(7.0*(p5(1)+p5(5)) + 32.0*(p5(2)+p5(4)) + 12.0*p5(3)) - ! Get correction from difference between this and linear average. This is clunky and repetitive. - intx_pa_cor(I,j) = -0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa(I,j,1) + ! Get a correction from difference between this and linear average. + intx_pa_cor(I,j) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1) + pa5(5))) else ! Do not use 5-point quadrature. intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc endif @@ -995,7 +1029,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm do J=Jsq,Jeq ; do i=is,ie inty_pa_cor(i,J) = 0.0 dz_geo_sfc = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) - if (dz_geo_sfc * (rho_ref - (pa(i,j+1,1)-pa(i,j,1))*dz_geo_sfc) > 0.0) then + if ((dz_geo_sfc * rho_ref - (pa(i,j+1,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then ! The pressure/depth relationship has a positive implied density if (-dz_geo_sfc * (pa(i,j+1,1)-pa(i,j,1)) > & 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then @@ -1003,32 +1037,28 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. if (CS%correction_intxpa_5pt) then ! Use 5 point quadrature to calculate intypa - T5(1) = T_t(I,j,1) ; T5(5) = T_t(i,j+1,1) - S5(1) = S_t(I,j,1) ; S5(5) = S_t(i,j+1,1) + T5(1) = T_t(i,j,1) ; T5(5) = T_t(i,j+1,1) + S5(1) = S_t(i,j,1) ; S5(5) = S_t(i,j+1,1) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. - p5(1) = pa(i,j,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) - p5(5) = pa(i,j+1,1) - (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p5(1) = pa(i,j,1) - GxRho*(e(i,j,1) - G%Z_ref) + p5(5) = pa(i,j+1,1) - GxRho*(e(i,j+1,1) - G%Z_ref) do m=2,4 wt_R = 0.25*real(m-1) - T5(m) = T5(1)+(T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); - S5(m) = S5(1)+(S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); - p5(m) = p5(1)+(p5(5)-p5(1))*wt_R + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R enddo !m call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - ! add rhoref back in - do m=1,5 - p5(m) = p5(m) + (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) - enddo do m=2,4 ! Make pressure curvature a difference from the linear fit of pressure between the two points ! Do this by integrating pressure between each of the 5 points and adding up ! This way integration direction doesn't matter when adding up pressure from previous point - p5(m) = p5(m-1) + ((0.25*(p5(5)-p5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & - 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) + pa5(m) = pa5(m-1) + ((0.25*(pa5(5)-pa5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & + 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) enddo - inty_pa(I,j,1) = C1_90*(7.0*(p5(1)+p5(5)) + 32.0*(p5(2)+p5(4)) + 12.0*p5(3)) - ! Get correction from difference between this and linear average. This is clunky and repetitive. - inty_pa_cor(I,j) = -0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa(I,j,1) + ! Get a correction from difference between this and linear average. + inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1) + pa5(5))) else ! Do not use 5-point quadrature. inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc endif @@ -1064,61 +1094,107 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo enddo - ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is - ! reset intxpa there, then adjust intxpa above and below using the same increments between interfaces as above. - ! Note: This currently assumes pressure varies quadratically along the bottom of the topmost non-vanished, - ! non-mass-weighted layer. Possibly 5 pt quadrature should be implemented as for the surface. if (CS%reset_intxpa_integral) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - kloop: do k=1,nz-1 - ! Check if both sides are nonvanished and mass-weighting is not activated in the subgrid interpolation. - if ((h(i,j,k)>CS%h_nonvanished) .and. (h(i+1,j,k)>CS%h_nonvanished)) then - if (.not. (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) > 0.0)) then - ! Calculate pressure at the bottom of this cell (pa are known) - ! then we have a "good estimate" for intxpa (it might have quadratic pressure dependence if sloped) - ! now we recalculate intx_pa and PFu at each level working up and then down - call calculate_density(T_t(i,j,k+1), S_t(i,j,k+1), pa(i,j,K+1), rho_tl, & - tv%eqn_of_state, rho_ref=rho_ref) - call calculate_density(T_t(i+1,j,k+1), S_t(i+1,j,k+1), pa(i+1,j,K+1), rho_tr, & - tv%eqn_of_state, rho_ref=rho_ref) - inty_pa_cor(I,j) = C1_12 * (rho_tr-rho_tl)*GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) - intx_pa(i,j,K+1) = 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + inty_pa_cor(I,j) - do k2=1,k - intx_pa(I,j,K-K2+1) = intx_pa(I,j,(K-K2+2)) - intx_dpa(i,j,k-k2+1) - enddo - do k2=k+2,nz - intx_pa(I,j,K2) = intx_pa(I,j,K2-1) + intx_dpa(i,j,k2-1) - enddo - exit kloop - endif ; endif - enddo kloop + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intxpa there, then adjust intxpa throughout the water column. + ! Note: This currently assumes pressure varies quadratically along the bottom of the topmost non-vanished, + ! non-mass-weighted layer. Possibly 5 pt quadrature should be implemented as for the surface. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_pa_nonlin(:,:) = 0.0 ; dgeo_x(:,:) = 0.0 ; intx_pa_cor_ri(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) enddo ; enddo + do k=1,nz-1 + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = pa(i,j,K+1) - GxRho*(e(i,j,K+1) - G%Z_ref) + p_int_E(I,j) = pa(i+1,j,K+1) - GxRho*(e(i+1,j,K+1) - G%Z_ref) + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo - do J=Jsq,Jeq+1 ; do i=is,ie+1 - kloop2: do k=1,nz-1 - ! Check if both sides are nonvanished and mass-weighting is not activated in the subgrid interpolation. - if ((h(i,j,k)>CS%h_nonvanished) .and. (h(i,j+1,k)>CS%h_nonvanished)) then - if (.not. (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) > 0.0)) then - ! calculate pressure at the bottom of this cell (pa are known) - ! then we have a "good estimate" for intxpa (it might have quadratic pressure dependence if sloped) - ! now we recalculate intx_pa and PFu at each level working up and then down - call calculate_density(T_t(i,j,k+1), S_t(i,j,k+1), pa(i,j,K+1), rho_tl, & - tv%eqn_of_state, rho_ref=rho_ref) - call calculate_density(T_t(i,j+1,k+1), S_t(i,j+1,k+1), pa(i,j+1,K+1), rho_tr, & - tv%eqn_of_state, rho_ref=rho_ref) - inty_pa_cor(i,J) = C1_12 * (rho_tr-rho_tl) * GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) - inty_pa(i,J,K+1) = 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + inty_pa_cor(i,J) - do k2=1,k - inty_pa(i,J,K-K2+1) = inty_pa(i,J,(K-K2+2)) - inty_dpa(i,J,k-k2+1) - enddo - do k2=k+2,nz - inty_pa(i,J,K2) = inty_pa(i,J,K2-1) + inty_dpa(i,J,k2-1) - enddo - exit kloop2 - endif ; endif - enddo kloop2 + do j=js,je + call calculate_density(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), rho_x_W(:,j), & + tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) + call calculate_density(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), rho_x_E(:,j), & + tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) + do I=Isq,Ieq + ! This expression assumes that density varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to intx_pa. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + intx_pa_cor_ri(I,j) = C1_12 * (rho_x_E(I,j)-rho_x_W(I,j)) * dgeo_x(I,j) - intx_pa_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_pa_nonlin(:,:) = 0.0 ; dgeo_y(:,:) = 0.0 ; inty_pa_cor_ri(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) enddo ; enddo - endif ! intx_pa and inty_pa are now reset and should be correct + do k=1,nz-1 + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = pa(i,j,K+1) - GxRho*(e(i,j,K+1) - G%Z_ref) + p_int_N(i,J) = pa(i,j+1,K+1) - GxRho*(e(i,j+1,K+1) - G%Z_ref) + inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + do J=Jsq,Jeq + call calculate_density(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), rho_y_S(:,J), & + tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) + call calculate_density(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), rho_y_N(:,J), & + tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) + do i=is,ie + ! This expression assumes that density varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to inty_pa. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + inty_pa_cor_ri(i,J) = C1_12 * (rho_y_N(i,J)-rho_y_S(i,J)) * dgeo_y(i,J) - inty_pa_nonlin(i,J) + enddo + enddo + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K) = intx_pa(I,j,K) + intx_pa_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K) = inty_pa(i,J,K) + inty_pa_cor_ri(i,J) + enddo ; enddo ; enddo + endif ! intx_pa and inty_pa have now been reset to reflect the properties of an unimpeded interface. ! Compute pressure gradient in x direction !$OMP parallel do default(shared) From 4cf15901ff276674cc69e316f3eb6f8fa85a4a85 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 29 Jul 2024 05:57:24 -0400 Subject: [PATCH 091/128] *Refactor CORRECTION_INTX_PA Refactored the CORRECTION_INTX_PA calculations to avoid multiple intermediate steps, while also adding comments documenting the derivation of the final expression. Also calculate the pressures used in the equation of state calls with the Boussinesq CORRECTION_INTX_PA and RESET_INTXPA_INTEGRAL options consistently with the other terms. These changes will change the answers when either of those options are in use, but are bitwise identical when they are not. --- src/core/MOM_PressureForce_FV.F90 | 110 +++++++++++++++++++++--------- 1 file changed, 76 insertions(+), 34 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 04e6ed7b96..869ef02520 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -963,7 +963,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) private(p_surf_EOS) do j=Jsq,Jeq+1 ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. - do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - G%Z_ref) ; enddo + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo call calculate_density(T_t(:,j,1), S_t(:,j,1), p_surf_EOS, rho_top(:,j), & tv%eqn_of_state, EOSdom, rho_ref=rho_ref) enddo @@ -971,7 +971,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) private(p_surf_EOS) do j=Jsq,Jeq+1 ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. - do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - G%Z_ref) ; enddo + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_surf_EOS, rho_top(:,j), & tv%eqn_of_state, EOSdom, rho_ref=rho_ref) enddo @@ -999,25 +999,23 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm T5(1) = T_t(i,j,1) ; T5(5) = T_t(i+1,j,1) S5(1) = S_t(i,j,1) ; S5(5) = S_t(i+1,j,1) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) - ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. - p5(1) = pa(i,j,1) - GxRho*(e(i,j,1) - G%Z_ref) - p5(5) = pa(i+1,j,1) - GxRho*(e(i+1,j,1) - G%Z_ref) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) do m=2,4 wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R p5(m) = p5(1) + (p5(5)-p5(1))*wt_R enddo !m call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - do m=2,4 - ! Make pressure curvature a difference from the linear fit of pressure between the two points - ! Do this by integrating pressure between each of the 5 points and adding up - ! This way integration direction doesn't matter when adding up pressure from previous point - pa5(m) = pa5(m-1) + ((0.25*(pa5(5)-pa5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & - 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) - enddo - ! Get a correction from difference between this and linear average. - intx_pa_cor(I,j) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1) + pa5(5))) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + ! The derivation for this expression is shown below in the y-direction version. + intx_pa_cor(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + ! Note that (4.75 + 5.5/2) / 90 = 1/12, so this is consistent with the linear result below. else ! Do not use 5-point quadrature. intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc endif @@ -1040,25 +1038,64 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm T5(1) = T_t(i,j,1) ; T5(5) = T_t(i,j+1,1) S5(1) = S_t(i,j,1) ; S5(5) = S_t(i,j+1,1) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) - ! Pressure input to density EOS is the actual pressure not adjusted for rho_ref. - p5(1) = pa(i,j,1) - GxRho*(e(i,j,1) - G%Z_ref) - p5(5) = pa(i,j+1,1) - GxRho*(e(i,j+1,1) - G%Z_ref) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + do m=2,4 wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R !Quadratic: + (T5(5)-T5(1))*B*wt_R*(wt_R-1); - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R !+ (S5(5)-S5(1))*B*wt_R*(wt_R-1); + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R p5(m) = p5(1) + (p5(5)-p5(1))*wt_R enddo !m call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - do m=2,4 - ! Make pressure curvature a difference from the linear fit of pressure between the two points - ! Do this by integrating pressure between each of the 5 points and adding up - ! This way integration direction doesn't matter when adding up pressure from previous point - pa5(m) = pa5(m-1) + ((0.25*(pa5(5)-pa5(1)) + 0.125*(r5(5)+r5(1))*dz_geo_sfc) - & - 0.125*(r5(m)+r5(m-1))*dz_geo_sfc) - enddo - ! Get a correction from difference between this and linear average. - inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1) + pa5(5))) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + inty_pa_cor(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + + ! The derivation of this correction follows: + + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! (which is equivalent to taking 4 trapezoidal rule integrals of the hydrostatic equation on + ! sub-segments), with a constant slope that is chosen so that the pressure anomalies at the + ! two ends of the segment agree with their known values. + ! d_geo_8 = 0.125*dz_geo_sfc + ! dpa_subseg = 0.25*(pa5(5)-pa5(1)) + & + ! 0.25*d_geo_8 * ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) + ! do m=2,4 + ! pa5(m) = pa5(m-1) + dpa_subseg - d_geo_8*(r5(m)+r5(m-1))) + ! enddo + + ! Explicitly finding expressions for the incremental pressures from the recursion relation above: + ! pa5(2) = 0.25*(3.*pa5(1) + pa5(5)) + 0.25*d_geo_8 * ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) ) + ! ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ! ( (r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3)) + & + ! ! (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) - 4.*(r5(3)+r5(2)) ) + ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + d_geo_8 * (0.5*(r5(5)-r5(1)) + (r5(4)-r5(2)) ) + ! ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * & + ! ! (2.0*(r5(5)-r5(1)) + 4.0*(r5(4)-r5(2)) + (r5(5)+r5(1)) + & + ! ! 2.0*(r5(4)+r5(2)) + 2.0*r5(3) - 4.*(r5(4)+r5(3))) + ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) ) + ! ! pa5(5) = pa5(5) + 0.25*d_geo_8 * & + ! ! ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + & + ! ! ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - 4.*(r5(5)+r5(4)) ) + ! pa5(5) = pa5(5) ! As it should. + + ! From these: + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) + (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + d_geo_8 * ( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + + ! Get the correction from the difference between the 5-point quadrature integral of pa5 and + ! its trapezoidal rule integral as: + ! inty_pa_cor(i,J) = C1_90*(7.0*(pa5(1)+pa5(5)) + 32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 0.5*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ((32.0*( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + & + ! (6.*(r5(5)-r5(1)) + 12.0*(r5(4)-r5(2)) )) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ( 38.0*(r5(5)-r5(1)) + 44.0*(r5(4)-r5(2)) ) + else ! Do not use 5-point quadrature. inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc endif @@ -1118,8 +1155,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! the interface below this cell (it might have quadratic pressure dependence if sloped) T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) - p_int_W(I,j) = pa(i,j,K+1) - GxRho*(e(i,j,K+1) - G%Z_ref) - p_int_E(I,j) = pa(i+1,j,K+1) - GxRho*(e(i+1,j,K+1) - G%Z_ref) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_W(I,j) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,K+1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) seek_x_cor(I,j) = .false. @@ -1161,8 +1201,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! the interface below this cell (it might have quadratic pressure dependence if sloped) T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) - p_int_S(i,J) = pa(i,j,K+1) - GxRho*(e(i,j,K+1) - G%Z_ref) - p_int_N(i,J) = pa(i,j+1,K+1) - GxRho*(e(i,j+1,K+1) - G%Z_ref) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_S(i,J) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,K+1) - Z_0p(i,j)) inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) seek_y_cor(i,J) = .false. From 15fd31c22e016c54c57af94cfc0cfeff47064c4d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 5 Aug 2024 09:50:01 -0400 Subject: [PATCH 092/128] *Non-Boussinesq code for RESET_INTXPA_INTEGRAL Added non-Boussinesq versions of the code that is exercised when CORRECTION_INTXPA_5PT and RESET_INTXPA_INTEGRAL are set to true. These options use the same names as in their Boussinesq forms, even though the arrays that are being adjusted are actually intx_za and inty_za. As a part of the testing of this commit, several checksums were added to the PressureForce_FV routines; these are enabled when DEBUG = True. The changes in this commit will change the answers in non-Boussinesq cases when either of those options are in use, but are bitwise identical when they are not, and all Boussinesq answers are bitwise identical. --- src/core/MOM_PressureForce_FV.F90 | 482 +++++++++++++++++++++++------- 1 file changed, 372 insertions(+), 110 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 869ef02520..8fa995d784 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -69,6 +70,7 @@ module MOM_PressureForce_FV !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: use_SSH_in_Z0p !< If true, adjust the height at which the pressure used in the !! equation of state is 0 to account for the displacement of the sea !! surface including adjustments for atmospheric or sea-ice pressure. @@ -159,11 +161,46 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt] SpV_top ! Specific volume anomaly of top layer used with correction_intxpa [R-1 ~> m3 kg-1] real, dimension(SZIB_(G),SZJ_(G)) :: & intx_za_cor ! Correction for curvature in intx_za [L2 T-2 ~> m2 s-2] real, dimension(SZI_(G),SZJB_(G)) :: & inty_za_cor ! Correction for curvature in inty_za [L2 T-2 ~> m2 s-2] + + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + SpV_x_W, SpV_x_E, & ! Specific volume anomalies on the reference interface to the east and west + ! of a u-point [R-1 ~> m3 kg-1] + intx_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dp_int_x, & ! The change in x in pressure along the reference interface [R L2 T-2 ~> Pa] + intx_za_cor_ri ! The correction to intx_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + SpV_y_S, SpV_y_N, & ! Specific volume anomalies on the reference interface to the north and south + ! of a v-point [R L2 T-2 ~> Pa] + inty_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [L2 T-2 ~> m2 s-2]. + dp_int_y, & ! The change in y in geopotenial height along the reference interface [R L2 T-2 ~> Pa] + inty_za_cor_ri ! The correction to inty_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & MassWt_u ! The fractional mass weighting at a u-point [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & @@ -180,6 +217,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used @@ -189,17 +227,28 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1]. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: SpV5(5) ! Specific volume anomalies at five quadrature points [R-1 ~> m3 kg-1] + real :: wt_R ! A weighting factor [nondim] + ! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] real, parameter :: C1_6 = 1.0/6.0 ! [nondim] real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points + integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") @@ -273,12 +322,14 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2) then + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif !$OMP parallel do default(shared) private(alpha_anom,dp) @@ -389,54 +440,108 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo + if (CS%debug) then + call hchksum(za, "Pre-correction za", G%HI, haloshift=1, unscale=US%L_T_to_m_s**2) + call hchksum(p, "Pre-correction p", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) + endif + ! With an ice-shelf or icebergs, this linearity condition might need to be applied ! to a sub-surface interface. if (CS%correction_intxpa) then - ! Determine surface specific volume for use in the pressure gradient corrections + ! Determine surface temperature and salinity for use in the pressure gradient corrections if (use_ALE .and. (CS%Recon_Scheme > 0)) then - do j=Jsq,Jeq+1 - call calculate_spec_vol(tv%T(:,j,1), tv%S(:,j,1), p(:,j,1), SpV_top(:,j), & - tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) - enddo - elseif (use_EOS) then - do j=Jsq,Jeq+1 - call calculate_spec_vol(tv%T(:,j,1), tv%S(:,j,1), p(:,j,1), SpV_top(:,j), & - tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) - enddo + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) + enddo ; enddo else - alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SpV_top(i,j) = alpha_anom + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif - ! This version attempts to correct for hydrostatic variations in surface pressure under ice. - !$OMP parallel do default(shared) private(dp_sfc) - do j=js,je ; do I=Isq,Ieq - intx_za_cor(I,j) = 0.0 - dp_sfc = (p(i+1,j,1) - p(i,j,1)) - ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, - ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then - ! The pressure/depth relationship has a positive implied specific volume. - ! In non-Bousinesq mode, no other restrictions seem to be needed, and even the test - ! above might be unnecessary, but a test for the implied specific volume being at least - ! half the average specific volume would be: - ! if ((alpha_ref - dza / dp) > 0.25*((SpV_top(i+1,j)+SpV_top(i,j)) + 2.0*alpha_ref)) & - intx_za_cor(I,j) = C1_12 * (SpV_top(i+1,j)-SpV_top(i,j)) * dp_sfc - endif - intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) - enddo ; enddo - !$OMP parallel do default(shared) private(dp_sfc) - do J=Jsq,Jeq ; do i=is,ie - inty_za_cor(i,J) = 0.0 - dp_sfc = (p(i,j+1,1) - p(i,j,1)) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then - ! The pressure/depth relationship has a positive implied specific volume. - inty_za_cor(i,J) = C1_12 * (SpV_top(i,j+1)-SpV_top(i,j)) * dp_sfc - endif - inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) - enddo ; enddo + if (CS%correction_intxpa_5pt) then + ! This version makes a 5 point quadrature correction for hydrostatic variations in surface + ! pressure under ice. + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + p5(1) = p(i,j,1) ; p5(5) = p(i+1,j,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + intx_za_cor(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + p5(1) = p(i,j,1) ; p5(5) = p(i,j+1,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + inty_za_cor(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo + else + ! This version makes a parabolic correction for hydrostatic variations in surface pressure under ice. + + ! Determine surface specific volume for use in the pressure gradient corrections + do j=Jsq,Jeq+1 + call calculate_spec_vol(T_top(:,j), S_top(:,j), p(:,j,1), SpV_top(:,j), & + tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) + enddo + + !$OMP parallel do default(shared) private(dp_sfc) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + ! In non-Bousinesq mode, no other restrictions seem to be needed, and even the test + ! above might be unnecessary, but a test for the implied specific volume being at least + ! half the average specific volume would be: + ! if ((alpha_ref - dza / dp) > 0.25*((SpV_top(i+1,j)+SpV_top(i,j)) + 2.0*alpha_ref)) & + intx_za_cor(I,j) = C1_12 * (SpV_top(i+1,j)-SpV_top(i,j)) * dp_sfc + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + inty_za_cor(i,J) = C1_12 * (SpV_top(i,j+1)-SpV_top(i,j)) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo + endif else ! This order of integrating upward and then downward again is necessary with ! a nonlinear equation of state, so that the surface geopotentials will go @@ -466,6 +571,131 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo + if (CS%debug) then + call uvchksum("Prelim int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("Prelim int[xy]_dza", intx_dza, inty_dza, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + if (CS%reset_intxpa_integral) then + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intx_za there, then adjust intx_za throughout the water column. + ! Note: This option currently assumes height varies quadratically along the bottom of the topmost non-vanished, + ! non-mass-weighted layer. Possibly 5 point quadrature should be implemented as for the surface. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_za_nonlin(:,:) = 0.0 ; intx_za_cor_ri(:,:) = 0.0 ; dp_int_x(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) + enddo ; enddo + do k=1,nz-1 + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i+1,j,K+1), p(i+1,j,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = p(i,j,K+1) ; p_int_E(I,j) = p(i+1,j,K+1) + + intx_za_nonlin(I,j) = intx_za(I,j,K+1) - 0.5*(za(i,j,K+1) + za(i+1,j,K+1)) + dp_int_x(I,j) = p(i+1,j,K+1)-p(i,j,K+1) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + do j=js,je + call calculate_spec_vol(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), SpV_x_W(:,j), & + tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) + call calculate_spec_vol(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), SpV_x_E(:,j), & + tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) + do I=Isq,Ieq + ! This expression assumes that specific volume varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to intx_za. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + intx_za_cor_ri(I,j) = C1_12 * (SpV_x_E(I,j)-SpV_x_W(I,j)) * dp_int_x(I,j) - intx_za_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_za_nonlin(:,:) = 0.0 ; inty_za_cor_ri(:,:) = 0.0 ; dp_int_y(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) + enddo ; enddo + do k=1,nz-1 + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i,j+1,K+1), p(i,j+1,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = p(i,j,K+1) ; p_int_N(i,J) = p(i,j+1,K+1) + inty_za_nonlin(i,J) = inty_za(i,J,K+1) - 0.5*(za(i,j,K+1) + za(i,j+1,K+1)) + dp_int_y(i,J) = p(i,j+1,K+1) - p(i,j,K+1) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + do J=Jsq,Jeq + call calculate_spec_vol(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), SpV_y_S(:,J), & + tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) + call calculate_spec_vol(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), SpV_y_N(:,J), & + tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) + do i=is,ie + ! This expression assumes that specific volume varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to inty_pa. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + inty_za_cor_ri(i,J) = C1_12 * (SpV_y_N(i,J)-SpV_y_S(i,J)) * dp_int_y(i,J) - inty_za_nonlin(i,J) + enddo + enddo + + if (CS%debug) then + call uvchksum("Pre-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_cor", intx_za_cor_ri, inty_za_cor_ri, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_nonlin", intx_za_nonlin, inty_za_nonlin, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("dp_int_[xy]", dp_int_x, dp_int_y, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, unscale=US%RL2_T2_to_Pa) + endif + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K) = intx_za(I,j,K) + intx_za_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K) = inty_za(i,J,K) + inty_za_cor_ri(i,J) + enddo ; enddo ; enddo + + if (CS%debug) then + call uvchksum("Post-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + endif ! intx_za and inty_za have now been reset to reflect the properties of an unimpeded interface. + !$OMP parallel do default(shared) private(dp) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -665,6 +895,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & MassWt_v ! The fractional mass weighting at a v-point [nondim]. real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt] rho_top ! Density anomaly of top layer used in calculating intx_pa_cor and inty_pa_cor real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance @@ -700,16 +932,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k, m, k2 - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] - real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] - real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five - ! quadrature points [R L2 T-2 ~> Pa]. - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five quadrature points [R L2 T-2 ~> Pa]. + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: wt_R ! A weighting factor [nondim] real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] - real :: wt_R ! A weighting factor [nondim] - real :: rho_tr, rho_tl ! Store right and left densities in reset intxpa calculation [R ~> kg m-3] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies @@ -853,12 +1084,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then - call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2 ) then - call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif ! Set the surface boundary conditions on pressure anomaly and its horizontal @@ -957,29 +1190,30 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo if (CS%correction_intxpa) then - - ! Determine surface density for use in the pressure gradient corrections - if (use_ALE .and. CS%Recon_Scheme > 0) then - !$OMP parallel do default(shared) private(p_surf_EOS) - do j=Jsq,Jeq+1 - ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. - do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo - call calculate_density(T_t(:,j,1), S_t(:,j,1), p_surf_EOS, rho_top(:,j), & - tv%eqn_of_state, EOSdom, rho_ref=rho_ref) - enddo - elseif (use_EOS) then - !$OMP parallel do default(shared) private(p_surf_EOS) - do j=Jsq,Jeq+1 - ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. - do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_surf_EOS, rho_top(:,j), & - tv%eqn_of_state, EOSdom, rho_ref=rho_ref) - enddo - else ! T and S are not state variables. - !$OMP parallel do default(shared) + ! Determine surface temperature and salinity for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - rho_top(i,j) = GV%Rlay(1) - rho_ref + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) + enddo ; enddo + endif + + ! Determine surface density for use in the pressure gradient corrections + !$OMP parallel do default(shared) private(p_surf_EOS) + do j=Jsq,Jeq+1 + ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo + call calculate_density(T_top(:,j), S_top(:,j), p_surf_EOS, rho_top(:,j), & + tv%eqn_of_state, EOSdom, rho_ref=rho_ref) + enddo + + if (CS%debug) then + call hchksum(rho_top, "intx_pa rho_top", G%HI, haloshift=1, unscale=US%R_to_kg_m3) + call hchksum(e(:,:,1), "intx_pa e(1)", G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(pa(:,:,1), "intx_pa pa(1)", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) endif ! This version attempts to correct for hydrostatic variations in surface pressure under ice. @@ -996,8 +1230,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. if (CS%correction_intxpa_5pt) then ! Use 5 point quadrature to calculate intxpa - T5(1) = T_t(i,j,1) ; T5(5) = T_t(i+1,j,1) - S5(1) = S_t(i,j,1) ; S5(5) = S_t(i+1,j,1) + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) @@ -1035,8 +1269,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. if (CS%correction_intxpa_5pt) then ! Use 5 point quadrature to calculate intypa - T5(1) = T_t(i,j,1) ; T5(5) = T_t(i,j+1,1) - S5(1) = S_t(i,j,1) ; S5(5) = S_t(i,j+1,1) + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) @@ -1103,6 +1337,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) enddo ; enddo + + if (CS%debug) then + call uvchksum("int[xy]_pa_cor", intx_pa_cor, inty_pa_cor, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + call uvchksum("int[xy]_pa(1)", intx_pa(:,:,1), inty_pa(:,:,1), G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + endif + else ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, ! assuming that the surface pressure anomaly varies linearly in x and y. @@ -1151,18 +1393,18 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! activated in the subgrid interpolation. if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) <= 0.0)) then - ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at - ! the interface below this cell (it might have quadratic pressure dependence if sloped) - T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) - S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) - ! These pressures are only used for the equation of state, and are only a function of - ! height, consistent with the expressions in the int_density_dz routines. - p_int_W(I,j) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) - p_int_E(I,j) = -GxRho*(e(i+1,j,K+1) - Z_0p(i,j)) - - intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) - dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) - seek_x_cor(I,j) = .false. + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_W(I,j) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,K+1) - Z_0p(i,j)) + + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + seek_x_cor(I,j) = .false. else do_more_k = .true. endif @@ -1197,17 +1439,17 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! activated in the subgrid interpolation. if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) <= 0.0)) then - ! Store properties at the bottom of this cell to get a "good estimate" for intypa at - ! the interface below this cell (it might have quadratic pressure dependence if sloped) - T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) - S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) - ! These pressures are only used for the equation of state, and are only a function of - ! height, consistent with the expressions in the int_density_dz routines. - p_int_S(i,J) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) - p_int_N(i,J) = -GxRho*(e(i,j+1,K+1) - Z_0p(i,j)) - inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) - dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) - seek_y_cor(i,J) = .false. + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_S(i,J) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,K+1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) + seek_y_cor(i,J) = .false. else do_more_k = .true. endif @@ -1401,6 +1643,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] integer :: default_answer_date ! Global answer date + 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. logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S logical :: MassWghtInterpTop ! If true, use near-surface mass weighting for T and S under ice shelves logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq @@ -1418,6 +1662,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "RHO_PGF_REF", CS%Rho0, & "The reference density that is subtracted off when calculating pressure "//& "gradient forces. Its inverse is subtracted off of specific volumes when "//& @@ -1437,6 +1684,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) + + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state variables.", & + default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "USE_EOS", use_EOS, & + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& + "true, ENABLE_THERMODYNAMICS must be true as well.", & + default=use_temperature, do_not_log=.true.) + call get_param(param_file, mdl, "SSH_IN_EOS_PRESSURE_FOR_PGF", CS%use_SSH_in_Z0p, & "If true, include contributions from the sea surface height in the height-based "//& "pressure used in the equation of state calculations for the Boussinesq pressure "//& @@ -1468,15 +1725,20 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 - call get_param(param_file, mdl, "CORRECTION_INTXPA",CS%correction_intxpa, & + call get_param(param_file, mdl, "CORRECTION_INTXPA", CS%correction_intxpa, & "If true, use a correction for surface pressure curvature in intx_pa.", & - default = .false.) + default=.false., do_not_log=.not.use_EOS) call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT", CS%correction_intxpa_5pt, & "If true, use 5point quadrature to calculate intxpa. This requires "//& - "CORRECTION_INTXPA = True.",default = .false.) + "CORRECTION_INTXPA = True.", default=.false., do_not_log=.not.use_EOS) call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & "If true, reset INTXPA to match pressures at first nonvanished cell. "//& - "Includes pressure correction. ", default = .false.) + "Includes pressure correction.", default=.false., do_not_log=.not.use_EOS) + if (.not.use_EOS) then ! These options do nothing without an equation of state. + CS%correction_intxpa = .false. + CS%correction_intxpa_5pt = .false. + CS%reset_intxpa_integral = .false. + endif call get_param(param_file, mdl, "RESET_INTXPA_H_NONVANISHED", CS%h_nonvanished, & "A minimal layer thickness that indicates that a layer is thick enough to usefully "//& "reestimate the pressure integral across the interface below.", & From 5fceecfbc6a705f1911866dc227e5c0ff28b9a78 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Aug 2024 07:44:18 -0400 Subject: [PATCH 093/128] +(*)Add 5-point quadrature in RESET_INTXPA_INTEGRAL Added code to do 5-point quadrature integrals when RESET_INTXPA_INTEGRAL and CORRECTION_INTXPA_5PT are true. Also extended the ranged of interfaces that can be used for the corrections to include the bottom interface and use the surface interface for the nonlinear pressure gradient force corrections either when the ocean surface interface is within the pressure or height range of the top cell, or when no appropriate interior interface has been found (for lack of a better idea). This latter case should probably be reconsidered later. This commit will change answers if RESET_INTXPA_INTEGRAL is true and one description of a runtime parameter in the MOM_parameter_doc files has been revised. --- src/core/MOM_PressureForce_FV.F90 | 313 ++++++++++++++++++++++++------ 1 file changed, 257 insertions(+), 56 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 8fa995d784..dedd86554c 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -447,7 +447,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! With an ice-shelf or icebergs, this linearity condition might need to be applied ! to a sub-surface interface. - if (CS%correction_intxpa) then + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then ! Determine surface temperature and salinity for use in the pressure gradient corrections if (use_ALE .and. (CS%Recon_Scheme > 0)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -458,7 +458,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif + endif + if (CS%correction_intxpa) then if (CS%correction_intxpa_5pt) then ! This version makes a 5 point quadrature correction for hydrostatic variations in surface ! pressure under ice. @@ -581,8 +583,6 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%reset_intxpa_integral) then ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is ! reset intx_za there, then adjust intx_za throughout the water column. - ! Note: This option currently assumes height varies quadratically along the bottom of the topmost non-vanished, - ! non-mass-weighted layer. Possibly 5 point quadrature should be implemented as for the surface. ! Zero out the 2-d arrays that will be set from various reference interfaces. T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 @@ -591,7 +591,20 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ do j=js,je ; do I=Isq,Ieq seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) enddo ; enddo - do k=1,nz-1 + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((p(i+1,j,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i+1,j,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz do_more_k = .false. do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not @@ -614,18 +627,54 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. enddo - do j=js,je - call calculate_spec_vol(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), SpV_x_W(:,j), & - tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) - call calculate_spec_vol(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), SpV_x_E(:,j), & + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + + if (CS%correction_intxpa_5pt) then + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_za_cor_ri(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_x(I,j) - intx_za_nonlin(I,j) + enddo + enddo + else + do j=js,je + call calculate_spec_vol(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), SpV_x_W(:,j), & + tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) + call calculate_spec_vol(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), SpV_x_E(:,j), & tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) - do I=Isq,Ieq - ! This expression assumes that specific volume varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to intx_za. - ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. - intx_za_cor_ri(I,j) = C1_12 * (SpV_x_E(I,j)-SpV_x_W(I,j)) * dp_int_x(I,j) - intx_za_nonlin(I,j) + do I=Isq,Ieq + ! This expression assumes that specific volume varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to intx_za. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + intx_za_cor_ri(I,j) = C1_12 * (SpV_x_E(I,j)-SpV_x_W(I,j)) * dp_int_x(I,j) - intx_za_nonlin(I,j) + enddo enddo - enddo + endif ! Repeat the calculations above for v-velocity points. T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 @@ -634,7 +683,20 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ do J=Jsq,Jeq ; do i=is,ie seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) enddo ; enddo - do k=1,nz-1 + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((p(i,j+1,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i,j+1,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz do_more_k = .false. do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not @@ -656,18 +718,54 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. enddo - do J=Jsq,Jeq - call calculate_spec_vol(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), SpV_y_S(:,J), & - tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) - call calculate_spec_vol(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), SpV_y_N(:,J), & - tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) - do i=is,ie - ! This expression assumes that specific volume varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to inty_pa. - ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. - inty_za_cor_ri(i,J) = C1_12 * (SpV_y_N(i,J)-SpV_y_S(i,J)) * dp_int_y(i,J) - inty_za_nonlin(i,J) + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + + if (CS%correction_intxpa_5pt) then + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_za_cor_ri(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_y(i,J) - inty_za_nonlin(i,J) + enddo enddo - enddo + else + do J=Jsq,Jeq + call calculate_spec_vol(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), SpV_y_S(:,J), & + tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) + call calculate_spec_vol(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), SpV_y_N(:,J), & + tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) + do i=is,ie + ! This expression assumes that specific volume varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to inty_pa. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + inty_za_cor_ri(i,J) = C1_12 * (SpV_y_N(i,J)-SpV_y_S(i,J)) * dp_int_y(i,J) - inty_za_nonlin(i,J) + enddo + enddo + endif if (CS%debug) then call uvchksum("Pre-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & @@ -1189,7 +1287,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo enddo - if (CS%correction_intxpa) then + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then ! Determine surface temperature and salinity for use in the pressure gradient corrections if (use_ALE .and. (CS%Recon_Scheme > 0)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1200,7 +1298,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif + endif + if (CS%correction_intxpa) then ! Determine surface density for use in the pressure gradient corrections !$OMP parallel do default(shared) private(p_surf_EOS) do j=Jsq,Jeq+1 @@ -1376,8 +1476,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%reset_intxpa_integral) then ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is ! reset intxpa there, then adjust intxpa throughout the water column. - ! Note: This currently assumes pressure varies quadratically along the bottom of the topmost non-vanished, - ! non-mass-weighted layer. Possibly 5 pt quadrature should be implemented as for the surface. ! Zero out the 2-d arrays that will be set from various reference interfaces. T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 @@ -1386,7 +1484,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm do j=js,je ; do I=Isq,Ieq seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) enddo ; enddo - do k=1,nz-1 + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((e(i+1,j,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i+1,j,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz do_more_k = .false. do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not @@ -1412,18 +1524,55 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. enddo - do j=js,je - call calculate_density(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), rho_x_W(:,j), & - tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) - call calculate_density(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), rho_x_E(:,j), & - tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) - do I=Isq,Ieq - ! This expression assumes that density varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to intx_pa. - ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. - intx_pa_cor_ri(I,j) = C1_12 * (rho_x_E(I,j)-rho_x_W(I,j)) * dgeo_x(I,j) - intx_pa_nonlin(I,j) + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + + if (CS%correction_intxpa_5pt) then + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_pa_cor_ri(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_x(I,j) - & + intx_pa_nonlin(I,j) + enddo enddo - enddo + else + do j=js,je + call calculate_density(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), rho_x_W(:,j), & + tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) + call calculate_density(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), rho_x_E(:,j), & + tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) + do I=Isq,Ieq + ! This expression assumes that density varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to intx_pa. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + intx_pa_cor_ri(I,j) = C1_12 * (rho_x_E(I,j)-rho_x_W(I,j)) * dgeo_x(I,j) - intx_pa_nonlin(I,j) + enddo + enddo + endif ! Repeat the calculations above for v-velocity points. T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 @@ -1432,7 +1581,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm do J=Jsq,Jeq ; do i=is,ie seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) enddo ; enddo - do k=1,nz-1 + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((e(i,j+1,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i,j+1,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz do_more_k = .false. do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not @@ -1457,18 +1620,55 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. enddo - do J=Jsq,Jeq - call calculate_density(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), rho_y_S(:,J), & - tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) - call calculate_density(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), rho_y_N(:,J), & - tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) - do i=is,ie - ! This expression assumes that density varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to inty_pa. - ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. - inty_pa_cor_ri(i,J) = C1_12 * (rho_y_N(i,J)-rho_y_S(i,J)) * dgeo_y(i,J) - inty_pa_nonlin(i,J) + if (do_more_k) then + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + + if (CS%correction_intxpa_5pt) then + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_pa_cor_ri(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_y(i,J) - & + inty_pa_nonlin(i,J) + enddo enddo - enddo + else + do J=Jsq,Jeq + call calculate_density(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), rho_y_S(:,J), & + tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) + call calculate_density(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), rho_y_N(:,J), & + tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) + do i=is,ie + ! This expression assumes that density varies linearly with depth between the corners of the + ! reference interfaces found above to get a vertically uniform correction to inty_pa. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + inty_pa_cor_ri(i,J) = C1_12 * (rho_y_N(i,J)-rho_y_S(i,J)) * dgeo_y(i,J) - inty_pa_nonlin(i,J) + enddo + enddo + endif ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq @@ -1728,12 +1928,13 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "CORRECTION_INTXPA", CS%correction_intxpa, & "If true, use a correction for surface pressure curvature in intx_pa.", & default=.false., do_not_log=.not.use_EOS) - call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT", CS%correction_intxpa_5pt, & - "If true, use 5point quadrature to calculate intxpa. This requires "//& - "CORRECTION_INTXPA = True.", default=.false., do_not_log=.not.use_EOS) call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & "If true, reset INTXPA to match pressures at first nonvanished cell. "//& "Includes pressure correction.", default=.false., do_not_log=.not.use_EOS) + call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT", CS%correction_intxpa_5pt, & + "If true, use 5-point quadrature to calculate the corrections to intxpa or intxza. "//& + "This option only acts if CORRECTION_INTXPA = True or RESET_INTXPA_INTEGRAL = True.", & + default=.false., do_not_log=.not.use_EOS) if (.not.use_EOS) then ! These options do nothing without an equation of state. CS%correction_intxpa = .false. CS%correction_intxpa_5pt = .false. From bdf4b9e66ff28d4adf302d70d738e3e7cef627f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Sep 2024 05:42:42 -0400 Subject: [PATCH 094/128] +(*)Eliminate CORRECTION_INTXPA_5PT Eliminated the runtime parameter CORRECTION_INTXPA_5PT by always selecting the code that would have been used if it were true. This decision was based on the relative performance of the options with this set to true or false, and on the desire to maintain consistency with the 5-point Boole's rule quadrature used elsewhere in the pressure gradient force calculations. CORRECTION_INTXPA_5PT was only added in the same PR as this commit, so it can been simply removed and there is no need to obsolete it. This will change answers if CORRECTION_INTXPA or RESET_INTXPA_INTEGRAL are true and CORRECTION_INTXPA_5PT was set to false, but otherwise answers are bitwise identical. There are fewer entries in the MOM_parameter_doc files as a result of this commit. --- src/core/MOM_PressureForce_FV.F90 | 556 ++++++++++++------------------ 1 file changed, 224 insertions(+), 332 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index dedd86554c..42e6514ab9 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -49,9 +49,14 @@ module MOM_PressureForce_FV type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation - logical :: correction_intxpa !< If true, apply a correction to surface intxpa under ice. - logical :: correction_intxpa_5pt !< Use 5 point quadrature to calculate surface intxpa - logical :: reset_intxpa_integral !< In the interior, reset intxpa at a trusted cell (for ice shelf) + logical :: correction_intxpa !< If true, apply a correction to the value of intxpa at a selected + !! interface under ice, using matching at the end values along with a + !! 5-point quadrature integral of the hydrostatic pressure or height + !! changes along that interface. The selected interface is either at the + !! ocean's surface or in the interior, depending on reset_intxpa_integral. + logical :: reset_intxpa_integral !< If true and the surface displacement between adjacent cells + !! exceeds the vertical grid spacing, reset intxpa at the interface below + !! a trusted interior cell. (This often applies in ice shelf cavities.) real :: h_nonvanished !< A minimal layer thickness that indicates that a layer is thick enough !! to usefully reestimate the pressure integral across the interface !! below it [H ~> m or kg m-2] @@ -235,7 +240,6 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] real, parameter :: C1_6 = 1.0/6.0 ! [nondim] - real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -461,89 +465,52 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif if (CS%correction_intxpa) then - if (CS%correction_intxpa_5pt) then - ! This version makes a 5 point quadrature correction for hydrostatic variations in surface - ! pressure under ice. - !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) - do j=js,je ; do I=Isq,Ieq - intx_za_cor(I,j) = 0.0 - dp_sfc = (p(i+1,j,1) - p(i,j,1)) - ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, - ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then - T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) - S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) - p5(1) = p(i,j,1) ; p5(5) = p(i+1,j,1) - do m=2,4 - wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R - p5(m) = p5(1) + (p5(5)-p5(1))*wt_R - enddo !m - call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) - ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. - intx_za_cor(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc - ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 - endif - intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) - enddo ; enddo - !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) - do J=Jsq,Jeq ; do i=is,ie - inty_za_cor(i,J) = 0.0 - dp_sfc = (p(i,j+1,1) - p(i,j,1)) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then - ! The pressure/depth relationship has a positive implied specific volume. - T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) - S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) - p5(1) = p(i,j,1) ; p5(5) = p(i,j+1,1) - do m=2,4 - wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R - p5(m) = p5(1) + (p5(5)-p5(1))*wt_R - enddo !m - call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) - ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. - inty_za_cor(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc - endif - inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) - enddo ; enddo - else - ! This version makes a parabolic correction for hydrostatic variations in surface pressure under ice. - - ! Determine surface specific volume for use in the pressure gradient corrections - do j=Jsq,Jeq+1 - call calculate_spec_vol(T_top(:,j), S_top(:,j), p(:,j,1), SpV_top(:,j), & - tv%eqn_of_state, EOSdom, spv_ref=alpha_ref) - enddo - - !$OMP parallel do default(shared) private(dp_sfc) - do j=js,je ; do I=Isq,Ieq - intx_za_cor(I,j) = 0.0 - dp_sfc = (p(i+1,j,1) - p(i,j,1)) - ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, - ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then - ! The pressure/depth relationship has a positive implied specific volume. - ! In non-Bousinesq mode, no other restrictions seem to be needed, and even the test - ! above might be unnecessary, but a test for the implied specific volume being at least - ! half the average specific volume would be: - ! if ((alpha_ref - dza / dp) > 0.25*((SpV_top(i+1,j)+SpV_top(i,j)) + 2.0*alpha_ref)) & - intx_za_cor(I,j) = C1_12 * (SpV_top(i+1,j)-SpV_top(i,j)) * dp_sfc - endif - intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) - enddo ; enddo - !$OMP parallel do default(shared) private(dp_sfc) - do J=Jsq,Jeq ; do i=is,ie - inty_za_cor(i,J) = 0.0 - dp_sfc = (p(i,j+1,1) - p(i,j,1)) - if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then - ! The pressure/depth relationship has a positive implied specific volume. - inty_za_cor(i,J) = C1_12 * (SpV_top(i,j+1)-SpV_top(i,j)) * dp_sfc - endif - inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) - enddo ; enddo - endif + ! This version makes a 5 point quadrature correction for hydrostatic variations in surface + ! pressure under ice. + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + p5(1) = p(i,j,1) ; p5(5) = p(i+1,j,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + intx_za_cor(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + p5(1) = p(i,j,1) ; p5(5) = p(i,j+1,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + inty_za_cor(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo else ! This order of integrating upward and then downward again is necessary with ! a nonlinear equation of state, so that the surface geopotentials will go @@ -639,42 +606,27 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif ; enddo ; enddo endif - if (CS%correction_intxpa_5pt) then - do j=js,je - do I=Isq,Ieq - ! This expression assumes that temperature and salinity vary linearly with pressure - ! between the corners of the reference interfaces found above to get a correction to - ! intx_pa that takes nonlinearities in the equation of state into account. - ! It is derived from a 5 point quadrature estimate of the integral with a large-scale - ! linear correction so that the pressures and heights match at the end-points. It turns - ! out that this linear correction cancels out the mid-point specific volume. - ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. - T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) - T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) - T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) - S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) - p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) - call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) - - ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 - intx_za_cor_ri(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & - dp_int_x(I,j) - intx_za_nonlin(I,j) - enddo + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_za_cor_ri(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_x(I,j) - intx_za_nonlin(I,j) enddo - else - do j=js,je - call calculate_spec_vol(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), SpV_x_W(:,j), & - tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) - call calculate_spec_vol(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), SpV_x_E(:,j), & - tv%eqn_of_state, EOSdom_u, spv_ref=alpha_ref) - do I=Isq,Ieq - ! This expression assumes that specific volume varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to intx_za. - ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. - intx_za_cor_ri(I,j) = C1_12 * (SpV_x_E(I,j)-SpV_x_W(I,j)) * dp_int_x(I,j) - intx_za_nonlin(I,j) - enddo - enddo - endif + enddo ! Repeat the calculations above for v-velocity points. T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 @@ -730,42 +682,27 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif ; enddo ; enddo endif - if (CS%correction_intxpa_5pt) then - do J=Jsq,Jeq - do i=is,ie - ! This expression assumes that temperature and salinity vary linearly with pressure - ! between the corners of the reference interfaces found above to get a correction to - ! intx_pa that takes nonlinearities in the equation of state into account. - ! It is derived from a 5 point quadrature estimate of the integral with a large-scale - ! linear correction so that the pressures and heights match at the end-points. It turns - ! out that this linear correction cancels out the mid-point specific volume. - ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. - T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) - T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) - T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) - S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) - p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) - call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) - - ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 - inty_za_cor_ri(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & - dp_int_y(i,J) - inty_za_nonlin(i,J) - enddo + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_za_cor_ri(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_y(i,J) - inty_za_nonlin(i,J) enddo - else - do J=Jsq,Jeq - call calculate_spec_vol(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), SpV_y_S(:,J), & - tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) - call calculate_spec_vol(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), SpV_y_N(:,J), & - tv%eqn_of_state, EOSdom_v, spv_ref=alpha_ref) - do i=is,ie - ! This expression assumes that specific volume varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to inty_pa. - ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. - inty_za_cor_ri(i,J) = C1_12 * (SpV_y_N(i,J)-SpV_y_S(i,J)) * dp_int_y(i,J) - inty_za_nonlin(i,J) - enddo - enddo - endif + enddo if (CS%debug) then call uvchksum("Pre-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & @@ -1019,6 +956,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real :: dz_neglect ! A minimal thickness [Z ~> m], like e. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five quadrature points [R L2 T-2 ~> Pa]. + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: wt_R ! A weighting factor [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -1030,15 +975,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k, m, k2 - real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] - real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] - real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] - real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five quadrature points [R L2 T-2 ~> Pa]. - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] - real :: wt_R ! A weighting factor [nondim] - real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] - real, parameter :: C1_12 = 1.0/12.0 ! A rational constant [nondim] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies @@ -1328,31 +1264,27 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 0.25*((rho_top(i+1,j)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. - if (CS%correction_intxpa_5pt) then - ! Use 5 point quadrature to calculate intxpa - T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) - S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) - pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) - ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. - p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p5(5) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) - do m=2,4 - wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R - p5(m) = p5(1) + (p5(5)-p5(1))*wt_R - enddo !m - call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - - ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure - ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule - ! quadrature to find the integrated correction to the integral of pressure along the interface. - ! The derivation for this expression is shown below in the y-direction version. - intx_pa_cor(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc - ! Note that (4.75 + 5.5/2) / 90 = 1/12, so this is consistent with the linear result below. - else ! Do not use 5-point quadrature. - intx_pa_cor(I,j) = C1_12 * (rho_top(i+1,j)-rho_top(i,j)) * dz_geo_sfc - endif + ! Use 5 point quadrature to calculate intxpa + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + ! The derivation for this expression is shown below in the y-direction version. + intx_pa_cor(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + ! Note that (4.75 + 5.5/2) / 90 = 1/12, so this is consistent with the linear result below. endif endif intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa_cor(I,j) @@ -1367,72 +1299,67 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then ! The pressure difference is at least half the size of the difference expected by hydrostatic ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. - if (CS%correction_intxpa_5pt) then - ! Use 5 point quadrature to calculate intypa - T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) - S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) - pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) - ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. - p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p5(5) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) - - do m=2,4 - wt_R = 0.25*real(m-1) - T5(m) = T5(1) + (T5(5)-T5(1))*wt_R - S5(m) = S5(1) + (S5(5)-S5(1))*wt_R - p5(m) = p5(1) + (p5(5)-p5(1))*wt_R - enddo !m - call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - - ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure - ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule - ! quadrature to find the integrated correction to the integral of pressure along the interface. - inty_pa_cor(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc - - ! The derivation of this correction follows: - - ! Make pressure curvature a difference from the linear fit of pressure between the two points - ! (which is equivalent to taking 4 trapezoidal rule integrals of the hydrostatic equation on - ! sub-segments), with a constant slope that is chosen so that the pressure anomalies at the - ! two ends of the segment agree with their known values. - ! d_geo_8 = 0.125*dz_geo_sfc - ! dpa_subseg = 0.25*(pa5(5)-pa5(1)) + & - ! 0.25*d_geo_8 * ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - ! do m=2,4 - ! pa5(m) = pa5(m-1) + dpa_subseg - d_geo_8*(r5(m)+r5(m-1))) - ! enddo - - ! Explicitly finding expressions for the incremental pressures from the recursion relation above: - ! pa5(2) = 0.25*(3.*pa5(1) + pa5(5)) + 0.25*d_geo_8 * ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) ) - ! ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + 0.25*d_geo_8 * & - ! ! ( (r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3)) + & - ! ! (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) - 4.*(r5(3)+r5(2)) ) - ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + d_geo_8 * (0.5*(r5(5)-r5(1)) + (r5(4)-r5(2)) ) - ! ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * & - ! ! (2.0*(r5(5)-r5(1)) + 4.0*(r5(4)-r5(2)) + (r5(5)+r5(1)) + & - ! ! 2.0*(r5(4)+r5(2)) + 2.0*r5(3) - 4.*(r5(4)+r5(3))) - ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) ) - ! ! pa5(5) = pa5(5) + 0.25*d_geo_8 * & - ! ! ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + & - ! ! ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - 4.*(r5(5)+r5(4)) ) - ! pa5(5) = pa5(5) ! As it should. - - ! From these: - ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + 0.25*d_geo_8 * & - ! ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) + (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) - ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + d_geo_8 * ( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) - - ! Get the correction from the difference between the 5-point quadrature integral of pa5 and - ! its trapezoidal rule integral as: - ! inty_pa_cor(i,J) = C1_90*(7.0*(pa5(1)+pa5(5)) + 32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 0.5*(pa5(1)+pa5(5))) - ! inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1)+pa5(5))) - ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ((32.0*( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + & - ! (6.*(r5(5)-r5(1)) + 12.0*(r5(4)-r5(2)) )) - ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ( 38.0*(r5(5)-r5(1)) + 44.0*(r5(4)-r5(2)) ) - - else ! Do not use 5-point quadrature. - inty_pa_cor(i,J) = C1_12 * (rho_top(i,j+1)-rho_top(i,j)) * dz_geo_sfc - endif + ! Use 5 point quadrature to calculate intypa + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + inty_pa_cor(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + + ! The derivation of this correction follows: + + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! (which is equivalent to taking 4 trapezoidal rule integrals of the hydrostatic equation on + ! sub-segments), with a constant slope that is chosen so that the pressure anomalies at the + ! two ends of the segment agree with their known values. + ! d_geo_8 = 0.125*dz_geo_sfc + ! dpa_subseg = 0.25*(pa5(5)-pa5(1)) + & + ! 0.25*d_geo_8 * ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) + ! do m=2,4 + ! pa5(m) = pa5(m-1) + dpa_subseg - d_geo_8*(r5(m)+r5(m-1))) + ! enddo + + ! Explicitly finding expressions for the incremental pressures from the recursion relation above: + ! pa5(2) = 0.25*(3.*pa5(1) + pa5(5)) + 0.25*d_geo_8 * ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) ) + ! ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ! ( (r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3)) + & + ! ! (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) - 4.*(r5(3)+r5(2)) ) + ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + d_geo_8 * (0.5*(r5(5)-r5(1)) + (r5(4)-r5(2)) ) + ! ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * & + ! ! (2.0*(r5(5)-r5(1)) + 4.0*(r5(4)-r5(2)) + (r5(5)+r5(1)) + & + ! ! 2.0*(r5(4)+r5(2)) + 2.0*r5(3) - 4.*(r5(4)+r5(3))) + ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) ) + ! ! pa5(5) = pa5(5) + 0.25*d_geo_8 * & + ! ! ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + & + ! ! ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - 4.*(r5(5)+r5(4)) ) + ! pa5(5) = pa5(5) ! As it should. + + ! From these: + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) + (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + d_geo_8 * ( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + + ! Get the correction from the difference between the 5-point quadrature integral of pa5 and + ! its trapezoidal rule integral as: + ! inty_pa_cor(i,J) = C1_90*(7.0*(pa5(1)+pa5(5)) + 32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 0.5*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ((32.0*( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + & + ! (6.*(r5(5)-r5(1)) + 12.0*(r5(4)-r5(2)) )) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ( 38.0*(r5(5)-r5(1)) + 44.0*(r5(4)-r5(2)) ) endif endif inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) @@ -1537,42 +1464,27 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif ; enddo ; enddo endif - if (CS%correction_intxpa_5pt) then - do j=js,je - do I=Isq,Ieq - ! This expression assumes that temperature and salinity vary linearly with hieght - ! between the corners of the reference interfaces found above to get a correction to - ! intx_pa that takes nonlinearities in the equation of state into account. - ! It is derived from a 5 point quadrature estimate of the integral with a large-scale - ! linear correction so that the pressures and heights match at the end-points. It turns - ! out that this linear correction cancels out the mid-point density anomaly. - ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. - T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) - T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) - T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) - S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) - p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) - call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - - ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 - intx_pa_cor_ri(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_x(I,j) - & - intx_pa_nonlin(I,j) - enddo - enddo - else - do j=js,je - call calculate_density(T_int_W(:,j), S_int_W(:,j), p_int_W(:,j), rho_x_W(:,j), & - tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) - call calculate_density(T_int_E(:,j), S_int_E(:,j), p_int_E(:,j), rho_x_E(:,j), & - tv%eqn_of_state, EOSdom_u, rho_ref=rho_ref) - do I=Isq,Ieq - ! This expression assumes that density varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to intx_pa. - ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. - intx_pa_cor_ri(I,j) = C1_12 * (rho_x_E(I,j)-rho_x_W(I,j)) * dgeo_x(I,j) - intx_pa_nonlin(I,j) - enddo + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_pa_cor_ri(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_x(I,j) - & + intx_pa_nonlin(I,j) enddo - endif + enddo ! Repeat the calculations above for v-velocity points. T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 @@ -1633,42 +1545,27 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif ; enddo ; enddo endif - if (CS%correction_intxpa_5pt) then - do J=Jsq,Jeq - do i=is,ie - ! This expression assumes that temperature and salinity vary linearly with hieght - ! between the corners of the reference interfaces found above to get a correction to - ! intx_pa that takes nonlinearities in the equation of state into account. - ! It is derived from a 5 point quadrature estimate of the integral with a large-scale - ! linear correction so that the pressures and heights match at the end-points. It turns - ! out that this linear correction cancels out the mid-point density anomaly. - ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. - T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) - T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) - T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) - S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) - p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) - call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) - - ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 - inty_pa_cor_ri(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_y(i,J) - & - inty_pa_nonlin(i,J) - enddo + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_pa_cor_ri(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_y(i,J) - & + inty_pa_nonlin(i,J) enddo - else - do J=Jsq,Jeq - call calculate_density(T_int_S(:,J), S_int_S(:,J), p_int_S(:,J), rho_y_S(:,J), & - tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) - call calculate_density(T_int_N(:,J), S_int_N(:,J), p_int_N(:,J), rho_y_N(:,J), & - tv%eqn_of_state, EOSdom_v, rho_ref=rho_ref) - do i=is,ie - ! This expression assumes that density varies linearly with depth between the corners of the - ! reference interfaces found above to get a vertically uniform correction to inty_pa. - ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. - inty_pa_cor_ri(i,J) = C1_12 * (rho_y_N(i,J)-rho_y_S(i,J)) * dgeo_y(i,J) - inty_pa_nonlin(i,J) - enddo - enddo - endif + enddo ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq @@ -1931,13 +1828,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & "If true, reset INTXPA to match pressures at first nonvanished cell. "//& "Includes pressure correction.", default=.false., do_not_log=.not.use_EOS) - call get_param(param_file, mdl, "CORRECTION_INTXPA_5PT", CS%correction_intxpa_5pt, & - "If true, use 5-point quadrature to calculate the corrections to intxpa or intxza. "//& - "This option only acts if CORRECTION_INTXPA = True or RESET_INTXPA_INTEGRAL = True.", & - default=.false., do_not_log=.not.use_EOS) if (.not.use_EOS) then ! These options do nothing without an equation of state. CS%correction_intxpa = .false. - CS%correction_intxpa_5pt = .false. CS%reset_intxpa_integral = .false. endif call get_param(param_file, mdl, "RESET_INTXPA_H_NONVANISHED", CS%h_nonvanished, & From 0363d2bd46b30326c74934f5fd2dde527d73a7cc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Sep 2024 18:01:15 -0400 Subject: [PATCH 095/128] *Set MASS_WEIGHT_IN_PRESSURE_GRADIENT in .testing Set MASS_WEIGHT_IN_PRESSURE_GRADIENT = True in the MOM_input files for the tc1, tc2 and tc4 test cases in .testing, to permit the code to pass this testing while dealing with inconsistent settings for two diagnostics related to the mass-weighting in the pressure gradient forces. This commit redefines these 3 test cases. --- .testing/tc1/MOM_input | 6 ++++++ .testing/tc2/MOM_input | 7 ++++++- .testing/tc4/MOM_input | 3 +++ 3 files changed, 15 insertions(+), 1 deletion(-) diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 151c093ff9..04204bd67f 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -278,6 +278,12 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + + ! === module MOM_hor_visc === AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index c7d2a35aa6..e142c64ff8 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -302,11 +302,16 @@ PGF_STANLEY_T2_DET_COEFF = -1.0 ! [nondim] default = -1.0 ! gradient in the deterministic part of the Stanley form of the Brankart ! correction. Negative values disable the scheme. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + ! === module MOM_hor_visc === LAPLACIAN = True KH_VEL_SCALE = 0.05 SMAGORINSKY_KH = True ! [Boolean] default = False -SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 +SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of ! the grid spacing to calculate the Laplacian viscosity. diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 591ed4c788..c4ef8475a9 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -269,6 +269,9 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! === module MOM_PressureForce === ! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True ! If True, use vertical reconstruction of T & S within the integrals of the FV ! pressure gradient calculation. If False, use the constant-by-layer algorithm. From 1830b8e682e3f69277f0c0acfc644d3212132a77 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Sep 2024 13:58:38 -0400 Subject: [PATCH 096/128] Dummy code to suppress errors in posix.F90 Adding null read operations so that compilers will not warn about unused input variables in dummy functions. --- src/framework/posix.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 1087958939..a9829c510e 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -437,6 +437,7 @@ function setjmp_missing(env) result(rc) bind(c) error stop ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state rc = -1 end function setjmp_missing @@ -450,6 +451,9 @@ subroutine longjmp_missing(env, val) bind(c) print '(a)', 'ERROR: longjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DLONGJMP_NAME=\"\".' error stop + + read env%state + read char(val) end subroutine longjmp_missing !> Placeholder function for a missing or unconfigured sigsetjmp @@ -466,6 +470,8 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) error stop ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state + read char(savesigs) rc = -1 end function sigsetjmp_missing @@ -478,6 +484,8 @@ subroutine siglongjmp_missing(env, val) bind(c) print '(a)', 'ERROR: siglongjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSIGLONGJMP_NAME=\"\".' + read env%state + read char(val) error stop end subroutine siglongjmp_missing From e05cc019eeae917de0d2d4e2a77ef485b129a8ce Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 9 Sep 2024 13:51:15 -0400 Subject: [PATCH 097/128] F2023: Fix argument orders and IO statements This is a minor patch which allows the code to be compiled under F2023 standardization. * Arguments are declared in the order that they are used. In this case, it means that array lengths are declared before the arrays using them. * The syntax of various IO statements has been cleaned up. --- src/equation_of_state/MOM_EOS.F90 | 5 +-- src/framework/MOM_domains.F90 | 6 +-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4 +- .../lateral/MOM_internal_tides.F90 | 42 +++++++++---------- .../lateral/MOM_mixed_layer_restrat.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 4 +- src/tracer/ideal_age_example.F90 | 4 +- 7 files changed, 34 insertions(+), 35 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index bfab3f5719..938634c1ea 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -2428,7 +2428,7 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & tol_here = 0.5*tol*(abs(SpV_avg_a(1)) + abs(SpV_avg_q(1))) test_OK = (abs(SpV_avg_a(1) - SpV_avg_q(1)) < tol_here) if (verbose) then - write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & SpV_avg_a(1), SpV_avg_q(1), SpV_avg_a(1) - SpV_avg_q(1), & 2.0*(SpV_avg_a(1) - SpV_avg_q(1)) / (abs(SpV_avg_a(1)) + abs(SpV_avg_q(1)) + tiny(SpV_avg_a(1))), & tol_here @@ -2508,8 +2508,7 @@ logical function check_FD(val, val_fd, tol, verbose, field_name, order) check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) - ! write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & - write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & val, val_fd(1), val - val_fd(1), & 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index d937ed7b0c..81e4425be3 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -680,10 +680,10 @@ subroutine write_auto_mask_file(mask_table, layout, npes, filename) true_num_masked_blocks = layout(1) * layout(2) - npes call open_ASCII_file(file_ascii, trim(filename), action=WRITEONLY_FILE) - write(file_ascii, '(I0)'), true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), layout(1), layout(2) + write(file_ascii, '(I0)') true_num_masked_blocks + write(file_ascii, '(I0,",",I0)') layout(1), layout(2) do p = 1, true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), mask_table(p,1), mask_table(p,2) + write(file_ascii, '(I0,",",I0)') mask_table(p,1), mask_table(p,2) enddo call close_file(file_ascii) end subroutine write_auto_mask_file diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 7816df32de..bee5cf11aa 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1122,7 +1122,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) else call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) if (abs(CS%timeunit - 86400.0) < 1.0) then - write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,"8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,",8x,"Energy/Mass,",13x,"Total Mass")') write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') else if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then @@ -1137,7 +1137,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit endif - write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,"7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,",7x,"Energy/Mass,",13x,"Total Mass")') write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units endif endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 819e77b2c2..f75707e581 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -510,7 +510,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after forcing') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after forcing', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after forcing', CS%En_sum enddo ; enddo endif @@ -537,7 +537,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 1/2 refraction', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 1/2 refraction', CS%En_sum enddo ; enddo ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -567,7 +567,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after correct halo rotation', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after correct halo rotation', CS%En_sum enddo ; enddo endif @@ -598,7 +598,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after propagate', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum enddo ; enddo ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -640,7 +640,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 2/2 refraction', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum enddo ; enddo ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -696,9 +696,9 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after background drag') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after background drag', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after background drag', CS%En_sum call sum_En(G, GV, US, CS, CS%TKE_leak_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after background drag') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after background drag', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after background drag', CS%En_sum enddo ; enddo ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -867,7 +867,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: before Froude drag') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: before Froude drag', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: before Froude drag', CS%En_sum enddo ; enddo ! save loss term for online budget, may want to add a debug flag later do m=1,CS%nMode ; do fr=1,CS%nFreq @@ -941,9 +941,9 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after Froude drag') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after Froude drag', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after Froude drag', CS%En_sum call sum_En(G, GV, US, CS, CS%TKE_Froude_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after Froude drag') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after Froude drag', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after Froude drag', CS%En_sum enddo ; enddo ! save loss term for online budget, may want to add a debug flag later do m=1,CS%nMode ; do fr=1,CS%nFreq @@ -1024,7 +1024,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & CS%En_end_glo(fr,m) - if (is_root_pe()) write(stdout,'(A,F18.10)'), "error in Energy budget", CS%error_mode(fr,m) + if (is_root_pe()) write(stdout,'(A,F18.10)') "error in Energy budget", CS%error_mode(fr,m) enddo ; enddo endif @@ -1612,23 +1612,23 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 enddo if (abs(verif_N -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)'), i, j, verif_N + write(stdout,'(I5,I5,F18.10)') i, j, verif_N call MOM_error(FATAL, "mismatch integral for N profile") endif if (abs(verif_N2 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)'), i, j, verif_N2 + write(stdout,'(I5,I5,F18.10)') i, j, verif_N2 call MOM_error(FATAL, "mismatch integral for N2 profile") endif if (abs(verif_bbl -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)'), i, j, verif_bbl + write(stdout,'(I5,I5,F18.10)') i, j, verif_bbl call MOM_error(FATAL, "mismatch integral for bbl profile") endif if (abs(verif_stl1 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl1 + write(stdout,'(I5,I5,F18.10)') i, j, verif_stl1 call MOM_error(FATAL, "mismatch integral for stl1 profile") endif if (abs(verif_stl2 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl2 + write(stdout,'(I5,I5,F18.10)') i, j, verif_stl2 call MOM_error(FATAL, "mismatch integral for stl2 profile") endif @@ -2108,7 +2108,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: top of routine') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: top of routine', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: top of routine', CS%En_sum enddo ; enddo endif @@ -2180,7 +2180,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_x', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_x', CS%En_sum enddo ; enddo endif @@ -2191,7 +2191,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after halo update', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after halo update', CS%En_sum enddo ; enddo endif ! Apply propagation in y-direction (reflection included) @@ -2210,7 +2210,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_y') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_y', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_y', CS%En_sum enddo ; enddo endif @@ -2219,7 +2219,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: bottom of routine') - if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: bottom of routine', CS%En_sum + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: bottom of routine', CS%En_sum enddo ; enddo endif diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index cf96017006..0d36ebf6d9 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1953,10 +1953,10 @@ logical function test_answer(verbose, u, u_true, label, tol) if (abs(u - u_true) > tolerance) test_answer = .true. if (test_answer .or. verbose) then if (test_answer) then - print '(3(a,1pe24.16),x,a,x,a)','computed =',u,' correct =',u_true, & + print '(3(a,1pe24.16),1x,a,1x,a)','computed =',u,' correct =',u_true, & ' err=',u-u_true,' < wrong',label else - print '(2(a,1pe24.16),x,a)','computed =',u,' correct =',u_true,label + print '(2(a,1pe24.16),1x,a)','computed =',u,' correct =',u_true,label endif endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index f4ef901868..47550fa93d 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -344,10 +344,10 @@ end subroutine find_N2_bottom !> Returns TKE_itidal_input subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nFreq !< number of frequencies real, dimension(SZI_(G),SZJ_(G),nFreq), & intent(out) :: TKE_itidal_input !< The energy input to the internal waves !! [H Z2 T-3 ~> m3 s-3 or W m-2]. - integer, intent(in) :: nFreq !< number of frequencies type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. integer :: i,j,fr @@ -361,9 +361,9 @@ end subroutine get_input_TKE !> Returns barotropic tidal velocities subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nFreq !< number of frequencies real, dimension(SZI_(G),SZJ_(G),nFreq), & intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. - integer, intent(in) :: nFreq !< number of frequencies type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. integer :: i,j,fr diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index cd781169af..147c48eebd 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -342,8 +342,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%use_real_BL_depth .and. .not. present(Hbl)) then - call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & - but no valid boundary layer scheme was found") + call MOM_error(FATAL, "Attempting to use real boundary layer depth for ideal age tracers, " & + // "but no valid boundary layer scheme was found") endif if (CS%use_real_BL_depth .and. present(Hbl)) then From b67e93abcfb74f2a4225e3a78e8da0690c709551 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 12 Sep 2024 12:33:17 -0400 Subject: [PATCH 098/128] Reorder arguments in FMS_cap functions Some functions in the FMS cap used arguments which depended on other arguments, which were declared out of order. * ocean_model_data2D_get * ocean_model_get_UV_surf This patch moves the array index size definitions before the array definitions. This is required for language standard compliance. --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 45c14e73eb..9c4359bf60 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1065,10 +1065,10 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain [various] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [various] integer :: g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed, i, j @@ -1188,10 +1188,10 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain [L T-1 ~> m s-1] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [L T-1 ~> m s-1] type(ocean_grid_type) , pointer :: G !< The ocean's grid structure type(surface), pointer :: sfc_state !< A structure containing fields that From b2db6bf6f7b76ba46c0e31cc61c075babea7c0fc Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 12 Sep 2024 12:07:12 -0400 Subject: [PATCH 099/128] CI: Fortran 2018 testing This patch enables Fortran 2018 standard compliance testing. We could do 2023, but our current CI of choice doesn't yet have a compiler which can do this. The actual content of this PR is a decoupling of FCFLAGS_DEBUG and FCFLAGS_FMS. There is now a default FCFLAGS macro which is used by the other two macros. One can now optionally configure FCFLAGS_DEBUG without worrying about the impact on FCFLAGS_FMS. The motivation here is that we don't want to test for F2018/2023 compliance in FMS. --- .github/actions/ubuntu-setup/action.yml | 2 +- .testing/Makefile | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 83d6795954..0f53a68c70 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -23,7 +23,7 @@ runs: run: | echo "::group::config.mk" cd .testing - echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_DEBUG = -g -O0 -std=f2018 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk diff --git a/.testing/Makefile b/.testing/Makefile index 085fea2655..adc1a20a1e 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -83,19 +83,21 @@ export FMS_URL # TODO: This needs more automated configuration MPIRUN ?= mpirun -# Generic compiler variables are pass through to the builds +# Generic compiler variables are passed through to the builds export CC export MPICC export FC export MPIFC # Builds are distinguished by FCFLAGS -FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS ?= -g -O0 + +FCFLAGS_DEBUG ?= $(FCFLAGS) FCFLAGS_REPRO ?= -g -O2 FCFLAGS_OPT ?= -g -O3 -mavx -fno-omit-frame-pointer FCFLAGS_INIT ?= FCFLAGS_COVERAGE ?= -g -O0 -fbacktrace --coverage -FCFLAGS_FMS ?= $(FCFLAGS_DEBUG) +FCFLAGS_FMS ?= $(FCFLAGS) # Additional notes: # - These default values are simple, minimalist flags, supported by nearly all # compilers, and are somewhat analogous to GFDL's DEBUG and REPRO builds. From b3d7348a954c28b1dd6718647eb07972193e24f0 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 12 Sep 2024 15:09:38 -0600 Subject: [PATCH 100/128] Change the default of VISC_REM_CONT_HVEL_FIX Temporarily cut off the control of VISC_REM_CONT_HVEL_FIX from VISC_REM_BUG and change the default of VISC_REM_CONT_HVEL_FIX to False. --- src/core/MOM_continuity_PPM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 46d5a99666..5fbf12a0d0 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -2778,7 +2778,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "VISC_REM_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & "If true, velocity cell thickness h_[uv] from the continuity solver "//& "is not multiplied by visc_rem_[uv]. Default of this flag is set by "//& - "VISC_REM_BUG.", default=.not.visc_rem_bug) + "VISC_REM_BUG.", default=.False.) !, default=.not.visc_rem_bug) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) From ba59078e742f2e33a07271f4fb9c75763b3c6b4c Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Wed, 18 Sep 2024 17:18:20 -0400 Subject: [PATCH 101/128] Separate scalar diagnostics for each ice sheet + parameters to control ice-sheet velocities (#714) * Updated with dev/gfdl. Then, added parameters for min ice thickness, min basal traction, max surf slope, and min ice viscosity to use for ice dynamics * noted how the MIN_BASAL_TRACTION parameter input is in units [Pa m-1 yr], but converts automatically to [Pa m-1 s] in the code * Added separate scalar ice-shelf diagnostics for Antarctica and Greenland * Added sx_shelf and sy_shelf as ice shelf diagnostics to save the surface slope fields used in the shallow shelf approximation (SSA). This is particularly helpful for determining whether unrealistic velocities are caused by unrealistically steep surface slopes, which can sometimes arise for example, on coarse grid cells that cover both a steep mountainous region and a realively flat ice shelf. Then, the MAX_SURFACE_SLOPE parameter can be tuned to set an upper bound on the SSA surface slope to avoid these steep-slope-induced problematic velocities. * Fix doxygen errors for ice-sheet process_and_post_scalar_data routine * FMA fix associated with enforcement of max allowed ice-shelf surface slope --- src/ice_shelf/MOM_ice_shelf.F90 | 500 +++++++++++++++++------ src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 129 ++++-- 2 files changed, 473 insertions(+), 156 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 4f811cac87..52b1ebdcea 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -181,6 +181,8 @@ module MOM_ice_shelf !! fluxes. It will avoid large increase in sea level. logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over !! the surface sponge cells from the ISOMIP/MISOMIP configuration + logical :: smb_diag !< If true, calculate diagnostics related to surface mass balance + logical :: bmb_diag !< If true, calculate diagnostics related to basal mass balance real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level !! is used [R Z ~> kg m-2] @@ -213,7 +215,17 @@ module MOM_ice_shelf id_bdott_melt = -1, id_bdott_accum = -1, id_bdott = -1, & id_dvafdt = -1, id_g_adot = -1, id_f_adot = -1, id_adot = -1, & id_bdot_melt = -1, id_bdot_accum = -1, id_bdot = -1, & - id_t_area = -1, id_g_area = -1, id_f_area = -1 + id_t_area = -1, id_g_area = -1, id_f_area = -1, & + id_Ant_vaf = -1, id_Ant_g_adott = -1, id_Ant_f_adott = -1, id_Ant_adott = -1, & + id_Ant_bdott_melt = -1, id_Ant_bdott_accum = -1, id_Ant_bdott = -1, & + id_Ant_dvafdt = -1, id_Ant_g_adot = -1, id_Ant_f_adot = -1, id_Ant_adot = -1, & + id_Ant_bdot_melt = -1, id_Ant_bdot_accum = -1, id_Ant_bdot = -1, & + id_Ant_t_area = -1, id_Ant_g_area = -1, id_Ant_f_area = -1, & + id_Gr_vaf = -1, id_Gr_g_adott = -1, id_Gr_f_adott = -1, id_Gr_adott = -1, & + id_Gr_bdott_melt = -1, id_Gr_bdott_accum = -1, id_Gr_bdott = -1, & + id_Gr_dvafdt = -1, id_Gr_g_adot = -1, id_Gr_f_adot = -1, id_Gr_adot = -1, & + id_Gr_bdot_melt = -1, id_Gr_bdot_accum = -1, id_Gr_bdot = -1, & + id_Gr_t_area = -1, id_Gr_g_area = -1, id_Gr_f_area = -1 !>@} type(external_field) :: mass_handle @@ -270,12 +282,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] - exch_vel_s, & !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] - tmp, & !< Temporary field used when calculating diagnostics [various] - dh_bdott, & !< Basal melt/accumulation over a time step, used for diagnostics [Z ~> m] - dh_adott !< Surface melt/accumulation over a time step, used for diagnostics [Z ~> m] - + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s, & !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + dh_bdott, & !< Basal melt/accumulation over a time step, used for diagnostics [Z ~> m] + dh_adott !< Surface melt/accumulation over a time step, used for diagnostics [Z ~> m] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & @@ -343,9 +353,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) character(len=160) :: mesg ! The text of an error message integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 - real :: vaf0, vaf ! The previous and current volume above floatation [m3] - logical :: smb_diag=.false., bmb_diag=.false. ! Flags to calculate diagnostics related to surface/basal mass balance - real :: val ! Temporary value when calculating scalar diagnostics [various] + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation [m3] + !for all ice sheets, Antarctica only, or Greenland only [m3] if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -356,13 +365,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) time_step = time_step_in Itime_step = 1./time_step - if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & - CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0 ) smb_diag=.true. - if (CS%id_bdott>0 .or. CS%id_bdott_melt>0 .or. CS%id_bdott_accum>0 .or. & - CS%id_bdot >0 .or. CS%id_bdot_melt >0 .or. CS%id_bdot_accum >0) bmb_diag=.true. + dh_adott(:,:)=0.0; dh_bdott(:,:)=0.0 - if (CS%active_shelf_dynamics .and. CS%id_dvafdt > 0) & !calculate previous volume above floatation - call volume_above_floatation(CS%dCS, G, ISS, vaf0) + if (CS%active_shelf_dynamics) then + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only + endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then @@ -766,9 +776,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then - if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) - if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) @@ -782,9 +792,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) - if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) - if (bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) @@ -792,9 +802,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) unscale=US%RZ_to_kg_m2) endif - if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) - if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, unscale=US%Z_to_m) @@ -846,69 +856,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) - !scalars - if (CS%active_shelf_dynamics) then - if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) - call volume_above_floatation(CS%dCS, G, ISS, vaf) - if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf - if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt - if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt - call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val) - if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) - if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Itime_step,CS%diag) - endif - if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt - call masked_var_grounded(G,CS%dCS,dh_adott,tmp) - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) - if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Itime_step,CS%diag) - endif - if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt - call masked_var_grounded(G,CS%dCS,dh_adott,tmp) - tmp(:,:) = dh_adott(:,:) - tmp(:,:) - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) - if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) - endif - endif - if (CS%id_bdott > 0 .or. CS%id_bdot > 0) then !bottom accumulation - bottom melt - call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val) - if (CS%id_bdott > 0) call post_scalar_data(CS%id_bdott,val ,CS%diag) - if (CS%id_bdot > 0) call post_scalar_data(CS%id_bdot ,val*Itime_step,CS%diag) - endif - if (CS%id_bdott_melt > 0 .or. CS%id_bdot_melt > 0) then !bottom melt - tmp(:,:)=0.0 - do j=js,je ; do i=is,ie - if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) - enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag) - if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag) - endif - if (CS%id_bdott_accum > 0 .or. CS%id_bdot_accum > 0) then !bottom accumulation - tmp(:,:)=0.0 - do j=js,je ; do i=is,ie - if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) - enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag) - if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag) - endif - if (CS%id_t_area > 0) then - tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) - call post_scalar_data(CS%id_t_area,val,CS%diag) - endif - if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then - tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) - if (CS%id_g_area > 0) then - call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) - call post_scalar_data(CS%id_g_area,val,CS%diag) - endif - if (CS%id_f_area > 0) then - call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) - call post_scalar_data(CS%id_f_area,val,CS%diag) - endif - endif + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_shelf) @@ -926,20 +874,43 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) end subroutine shelf_calc_flux -subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out) +subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out, hemisphere) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< Ice variable to integrate in arbitrary units [A ~> a] real, intent(in) :: var_scale !< Dimensional scaling for variable to integrate [a A-1 ~> 1] real, intent(out) :: var_out !< Variable integrated over the area of the ice sheet in arbitrary units [a m2] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + integer :: IS_ID ! local copy of hemisphere real, dimension(SZI_(G),SZJ_(G)) :: var_cell !< Variable integrated over the ice-sheet area of each cell !! in arbitrary units [a m2] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated integer :: i,j + if (present(hemisphere)) then + IS_ID=hemisphere + else + IS_ID=-1 + endif + + mask(:,:)=0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = G%jsc,G%jec; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo; enddo + else !All ice sheets + mask(G%isc:G%iec,G%jsc:G%jec)=ISS%hmask(G%isc:G%iec,G%jsc:G%jec) + endif + var_cell(:,:)=0.0 do j = G%jsc,G%jec; do i = G%isc,G%iec - if (ISS%hmask(i,j)>0) var_cell(i,j) = (var(i,j) * var_scale) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + if (mask(i,j)>0) var_cell(i,j) = (var(i,j) * var_scale) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) enddo; enddo + var_out = reproducing_sum(var_cell) end subroutine integrate_over_ice_sheet_area @@ -2031,11 +2002,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'ice shelf surface mass flux deposition from atmosphere', & 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif - !scalars (area integrated) + + !scalars (area integrated over all ice sheets) CS%id_vaf = register_scalar_field('ice_shelf_model', 'int_vaf', CS%diag%axesT1, CS%Time, & 'Area integrated ice sheet volume above floatation', 'm3') CS%id_adott = register_scalar_field('ice_shelf_model', 'int_a', CS%diag%axesT1, CS%Time, & - 'Area integrated (entire ice sheet) change in ice-sheet thickness ' //& + 'Area integrated change in ice-sheet thickness ' //& 'due to surface accum+melt during a DT_THERM time step', 'm3') CS%id_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground', CS%diag%axesT1, CS%Time, & 'Area integrated change in grounded ice-sheet thickness ' //& @@ -2051,16 +2023,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, CS%id_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum', CS%diag%axesT1, CS%Time, & 'Area integrated basal accumulation over ice shelves during a DT_THERM a time step', 'm3') CS%id_t_area = register_scalar_field('ice_shelf_model', 'tot_area', CS%diag%axesT1, CS%Time, & - 'Total area of entire ice-sheet', 'm2') + 'Total ice-sheet area', 'm2') CS%id_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float', CS%diag%axesT1, CS%Time, & 'Total area of floating ice shelves', 'm2') CS%id_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground', CS%diag%axesT1, CS%Time, & - 'Total area of grounded ice sheet', 'm2') - !scalars (area integrated rates) + 'Total area of grounded ice sheets', 'm2') + !scalars (area integrated rates over all ice sheets) CS%id_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot', CS%diag%axesT1, CS%Time, & 'Area integrated rate of change in ice-sheet volume above floatation', 'm3 s-1') CS%id_adot = register_scalar_field('ice_shelf_model', 'int_adot', CS%diag%axesT1, CS%Time, & - 'Area integrated (full ice sheet) rate of change in ice-sheet thickness due to surface accum+melt', 'm3 s-1') + 'Area integrated rate of change in ice-sheet thickness due to surface accum+melt', 'm3 s-1') CS%id_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground', CS%diag%axesT1, CS%Time, & 'Area integrated rate of change in grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') CS%id_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float', CS%diag%axesT1, CS%Time, & @@ -2072,6 +2044,111 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, CS%id_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum', CS%diag%axesT1, CS%Time, & 'Area integrated basal accumulation rate over ice shelves', 'm3 s-1') + !scalars (area integrated over the Antarctic ice sheet) + CS%id_Ant_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_A', CS%diag%axesT1, CS%Time, & + 'Area integrated Antarctic ice sheet volume above floatation', 'm3') + CS%id_Ant_adott = register_scalar_field('ice_shelf_model', 'int_a_A', CS%diag%axesT1, CS%Time, & + 'Area integrated (Antarctic ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_bdott = register_scalar_field('ice_shelf_model', 'int_b_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_Ant_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Antarctic ice shelves during a DT_THERM time step', 'm3') + CS%id_Ant_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Antarctic ice shelves during a DT_THERM a time step', 'm3') + CS%id_Ant_t_area = register_scalar_field('ice_shelf_model', 'tot_area_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic ice sheet', 'm2') + CS%id_Ant_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic floating ice shelves', 'm2') + CS%id_Ant_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic grounded ice sheet', 'm2') + !scalars (area integrated rates over the Antarctic ice sheet) + CS%id_Ant_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet volume above floatation', 'm3 s-1') + CS%id_Ant_adot = register_scalar_field('ice_shelf_model', 'int_adot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_Ant_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_Ant_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Antarctic ice shelves', 'm3 s-1') + CS%id_Ant_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Antarctic ice shelves', 'm3 s-1') + + !scalars (area integrated over the Greenland ice sheet) + CS%id_Gr_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_G', CS%diag%axesT1, CS%Time, & + 'Area integrated Greenland ice sheet volume above floatation', 'm3') + CS%id_Gr_adott = register_scalar_field('ice_shelf_model', 'int_a_G', CS%diag%axesT1, CS%Time, & + 'Area integrated (Greenland ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_bdott = register_scalar_field('ice_shelf_model', 'int_b_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3') + CS%id_Gr_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Greenland ice shelves during a DT_THERM time step', 'm3') + CS%id_Gr_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Greenland ice shelves during a DT_THERM a time step', 'm3') + CS%id_Gr_t_area = register_scalar_field('ice_shelf_model', 'tot_area_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland ice sheet', 'm2') + CS%id_Gr_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland floating ice shelves', 'm2') + CS%id_Gr_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland grounded ice sheet', 'm2') + !scalars (area integrated rates over the Greenland ice sheet) + CS%id_Gr_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet volume above floatation', 'm3 s-1') + CS%id_Gr_adot = register_scalar_field('ice_shelf_model', 'int_adot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland grounded ice-sheet thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland floating ice-shelf thickness due to surface accum+melt', 'm3 s-1') + CS%id_Gr_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-shelf thickness due to basal accum+melt', 'm3 s-1') + CS%id_Gr_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Greenland ice shelves', 'm3 s-1') + CS%id_Gr_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Greenland ice shelves', 'm3 s-1') + + !Flags to calculate diagnostics related to surface/basal mass balance + if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & + CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0 .or. & + CS%id_Ant_adott>0 .or. CS%id_Ant_g_adott>0 .or. CS%id_Ant_f_adott>0 .or. & + CS%id_Ant_adot >0 .or. CS%id_Ant_g_adot >0 .or. CS%id_Ant_f_adot >0 .or. & + CS%id_Gr_adott>0 .or. CS%id_Gr_g_adott>0 .or. CS%id_Gr_f_adott>0 .or. & + CS%id_Gr_adot >0 .or. CS%id_Gr_g_adot >0 .or. CS%id_Gr_f_adot >0) then + CS%smb_diag=.true. + else + CS%smb_diag=.false. + endif + + if (CS%id_bdott>0 .or. CS%id_bdott_melt>0 .or. CS%id_bdott_accum>0 .or. & + CS%id_bdot >0 .or. CS%id_bdot_melt >0 .or. CS%id_bdot_accum >0 .or. & + CS%id_Ant_bdott>0 .or. CS%id_Ant_bdott_melt>0 .or. CS%id_Ant_bdott_accum>0 .or. & + CS%id_Ant_bdot >0 .or. CS%id_Ant_bdot_melt >0 .or. CS%id_Ant_bdot_accum >0 .or. & + CS%id_Gr_bdott>0 .or. CS%id_Gr_bdott_melt>0 .or. CS%id_Gr_bdott_accum>0 .or. & + CS%id_Gr_bdot >0 .or. CS%id_Gr_bdot_melt >0 .or. CS%id_Gr_bdot_accum >0) then + CS%bmb_diag=.true. + else + CS%bmb_diag=.false. + endif + call MOM_IS_diag_mediator_close_registration(CS%diag) if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) @@ -2447,11 +2524,9 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. integer :: is, ie, js, je, i, j - real :: vaf0, vaf ! The previous and current volume above floatation [m3] - logical :: smb_diag=.false. ! Flags to calculate diagnostics related to surface/basal mass balance - real :: val ! Temporary value when calculating scalar diagnostics [various] + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation + !for all ice sheets, Antarctica only, or Greenland only [m3] real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - tmp, & ! Temporary field used when calculating diagnostics [various] dh_adott_sum, & ! Surface melt/accumulation over a full time step, used for diagnostics [Z ~> m] dh_adott ! Surface melt/accumulation over a partial time step, used for diagnostics [Z ~> m] @@ -2475,14 +2550,14 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) - if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & - CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0) then - smb_diag=.true. - dh_adott(:,:) = 0.0 ; dh_adott_sum(:,:) = 0.0 ; tmp(:,:) = 0.0 - endif + dh_adott(:,:)=0.0 + + if (CS%smb_diag) dh_adott_sum(:,:) = 0.0 - if (CS%id_dvafdt > 0) & !calculate previous volume above floatation - call volume_above_floatation(CS%dCS, G, ISS, vaf0) + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2497,9 +2572,9 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif - if (smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) - if (smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & + if (CS%smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & (ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je)) remaining_time = remaining_time - time_step @@ -2525,47 +2600,222 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf ,ISS%h_shelf ,CS%diag) if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf ,ISS%dhdt_shelf ,CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask ,ISS%hmask ,CS%diag) - if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Ifull_time_step, dh_adott, dh_adott*0.0) + call disable_averaging(CS%diag) + + call IS_dynamics_post_data(full_time_step, Time, CS%dCS, G) +end subroutine solo_step_ice_shelf + +!> Post_data calls for ice-sheet scalars +subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real :: vaf0 !< The previous volumes above floatation for all ice sheets [m3] + real :: vaf0_A !< The previous volumes above floatation for the Antarctic ice sheet [m3] + real :: vaf0_G !< The previous volumes above floatation for the Greenland ice sheet [m3] + real :: Itime_step !< Inverse of the time step [T-1 ~> s-1] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_adott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_bdott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: tmp ! Temporary field used when calculating diagnostics [various] + real :: vaf ! The current ice-sheet volume above floatation [m3] + real :: val ! Temporary value when calculating scalar diagnostics [various] + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe the ice-shelf state + integer :: is, ie, js, je, i, j + + G => CS%grid + US => CS%US + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + !---ALL ICE SHEET---! + if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) call volume_above_floatation(CS%dCS, G, ISS, vaf) - if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf - if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Ifull_time_step,CS%diag) !d(vaf)/dt + if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt - call integrate_over_ice_sheet_area(G, ISS, dh_adott_sum, US%Z_to_m, val) - if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) - if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Ifull_time_step,CS%diag) + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val) + if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) + if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Itime_step,CS%diag) endif if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt - call masked_var_grounded(G,CS%dCS,dh_adott_sum,tmp) + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) - if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Ifull_time_step,CS%diag) + if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) + if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Itime_step,CS%diag) endif if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt - call masked_var_grounded(G,CS%dCS,dh_adott_sum,tmp) - tmp(:,:) = dh_adott_sum(:,:) - tmp(:,:) + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + tmp(:,:) = dh_adott(:,:) - tmp(:,:) call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) - if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) - if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Ifull_time_step,CS%diag) + if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) + if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) endif - if (CS%id_t_area > 0) then + if (CS%id_bdott > 0 .or. CS%id_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val) + if (CS%id_bdott > 0) call post_scalar_data(CS%id_bdott,val ,CS%diag) + if (CS%id_bdot > 0) call post_scalar_data(CS%id_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_melt > 0 .or. CS%id_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag) + if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_accum > 0 .or. CS%id_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag) + if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_t_area > 0) then !ice sheet area tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) call post_scalar_data(CS%id_t_area,val,CS%diag) endif if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) - if (CS%id_g_area > 0) then + if (CS%id_g_area > 0) then !grounded only ice sheet area call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) call post_scalar_data(CS%id_g_area,val,CS%diag) endif - if (CS%id_f_area > 0) then + if (CS%id_f_area > 0) then !floating only ice sheet area (ice shelf area) call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) call post_scalar_data(CS%id_f_area,val,CS%diag) endif endif - call disable_averaging(CS%diag) - call IS_dynamics_post_data(full_time_step, Time, CS%dCS, G) -end subroutine solo_step_ice_shelf + !---ANTARCTICA ONLY---! + if (CS%id_Ant_vaf > 0 .or. CS%id_Ant_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=0) + if (CS%id_Ant_vaf > 0) call post_scalar_data(CS%id_Ant_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Ant_dvafdt > 0) call post_scalar_data(CS%id_Ant_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Ant_adott > 0 .or. CS%id_Ant_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_adott > 0) call post_scalar_data(CS%id_Ant_adott,val ,CS%diag) + if (CS%id_Ant_adot > 0) call post_scalar_data(CS%id_Ant_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_g_adott > 0 .or. CS%id_Ant_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_g_adott > 0) call post_scalar_data(CS%id_Ant_g_adott,val ,CS%diag) + if (CS%id_Ant_g_adot > 0) call post_scalar_data(CS%id_Ant_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_f_adott > 0 .or. CS%id_Ant_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + tmp(:,:) = dh_adott(:,:) - tmp(:,:) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_f_adott > 0) call post_scalar_data(CS%id_Ant_f_adott,val ,CS%diag) + if (CS%id_Ant_f_adot > 0) call post_scalar_data(CS%id_Ant_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott > 0 .or. CS%id_Ant_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott > 0) call post_scalar_data(CS%id_Ant_bdott,val ,CS%diag) + if (CS%id_Ant_bdot > 0) call post_scalar_data(CS%id_Ant_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_melt > 0 .or. CS%id_Ant_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott_melt > 0) call post_scalar_data(CS%id_Ant_bdott_melt,val ,CS%diag) + if (CS%id_Ant_bdot_melt > 0) call post_scalar_data(CS%id_Ant_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_accum > 0 .or. CS%id_Ant_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + if (CS%id_Ant_bdott_accum > 0) call post_scalar_data(CS%id_Ant_bdott_accum,val ,CS%diag) + if (CS%id_Ant_bdot_accum > 0) call post_scalar_data(CS%id_Ant_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_t_area,val,CS%diag) + endif + if (CS%id_Ant_g_area > 0 .or. CS%id_Ant_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_Ant_g_area > 0) then !grounded only ice sheet area + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_g_area,val,CS%diag) + endif + if (CS%id_Ant_f_area > 0) then !floating only ice sheet area (ice shelf area) + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=0) + call post_scalar_data(CS%id_Ant_f_area,val,CS%diag) + endif + endif + + !---GREENLAND ONLY---! + if (CS%id_Gr_vaf > 0 .or. CS%id_Gr_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=1) + if (CS%id_Gr_vaf > 0) call post_scalar_data(CS%id_Gr_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Gr_dvafdt > 0) call post_scalar_data(CS%id_Gr_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Gr_adott > 0 .or. CS%id_Gr_adot > 0) then !surface accumulation - surface melt + call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_adott > 0) call post_scalar_data(CS%id_Gr_adott,val ,CS%diag) + if (CS%id_Gr_adot > 0) call post_scalar_data(CS%id_Gr_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_g_adott > 0 .or. CS%id_Gr_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_g_adott > 0) call post_scalar_data(CS%id_Gr_g_adott,val ,CS%diag) + if (CS%id_Gr_g_adot > 0) call post_scalar_data(CS%id_Gr_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_f_adott > 0 .or. CS%id_Gr_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + tmp(:,:) = dh_adott(:,:) - tmp(:,:) + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_f_adott > 0) call post_scalar_data(CS%id_Gr_f_adott,val ,CS%diag) + if (CS%id_Gr_f_adot > 0) call post_scalar_data(CS%id_Gr_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott > 0 .or. CS%id_Gr_bdot > 0) then !bottom accumulation - bottom melt + call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott > 0) call post_scalar_data(CS%id_Gr_bdott,val ,CS%diag) + if (CS%id_Gr_bdot > 0) call post_scalar_data(CS%id_Gr_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_melt > 0 .or. CS%id_Gr_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott_melt > 0) call post_scalar_data(CS%id_Gr_bdott_melt,val ,CS%diag) + if (CS%id_Gr_bdot_melt > 0) call post_scalar_data(CS%id_Gr_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_accum > 0 .or. CS%id_Gr_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo; enddo + call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + if (CS%id_Gr_bdott_accum > 0) call post_scalar_data(CS%id_Gr_bdott_accum,val ,CS%diag) + if (CS%id_Gr_bdot_accum > 0) call post_scalar_data(CS%id_Gr_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_t_area,val,CS%diag) + endif + if (CS%id_Gr_g_area > 0 .or. CS%id_Gr_f_area > 0) then + tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + if (CS%id_Gr_g_area > 0) then !grounded only ice sheet area + call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_g_area,val,CS%diag) + endif + if (CS%id_Gr_f_area > 0) then !floating only ice sheet area (ice shelf area) + call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=1) + call post_scalar_data(CS%id_Gr_f_area,val,CS%diag) + endif + endif +end subroutine process_and_post_scalar_data !> \namespace mom_ice_shelf !! diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index bee5cf11aa..3ed262e5f3 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -50,10 +50,14 @@ module MOM_ice_shelf_dynamics !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet !! on q-points (B grid) [L T-1 ~> m s-1] - real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet + real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the zonal driving stress of the ice shelf/sheet !! on q-points (C grid) [R L2 T-2 ~> Pa] - real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet + real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional driving stress of the ice shelf/sheet !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: sx_shelf => NULL() !< the zonal surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] + real, pointer, dimension(:,:) :: sy_shelf => NULL() !< the meridional surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -107,7 +111,7 @@ module MOM_ice_shelf_dynamics !! of "linearized" basal stress (Pa) [R L3 T-1 ~> kg s-1] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), - !! units= Pa (m s-1)^(n_basal_fric) + !! units= Pa (s m-1)^(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -164,6 +168,11 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) [nondim] + real :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. + real :: min_basal_traction !< The minimum basal traction for grounded ice (Pa m-1 s) [R L T-1 ~> kg m-2 s-1] + real :: max_surface_slope !< The maximum allowed ice-sheet surface slope (to ignore, set to zero) [nondim] + real :: min_ice_visc !< The minimum allowed Glen's law ice viscosity (Pa s), in [R L2 T-1 ~> kg m-1 s-1]. + real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] @@ -221,7 +230,8 @@ module MOM_ice_shelf_dynamics integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & - id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1, & + id_sx_shelf = -1, id_sy_shelf = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging @@ -343,11 +353,13 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] - allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (s m-1)^n_sliding] allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%sx_shelf(isd:ied,jsd:jed), source=0.0) + allocate(CS%sy_shelf(isd:ied,jsd:jed), source=0.0) allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) @@ -378,7 +390,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) 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, & - "basal sliding coefficients", "Pa (m s-1)^n_sliding") + "basal sliding coefficients", "Pa (s m-1)^n_sliding") 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, & @@ -491,6 +503,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "The gravitational acceleration of the Earth.", & units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "MIN_H_SHELF", CS%min_h_shelf, & + "min. ice thickness used during ice dynamics", & + units="m", default=0.,scale=US%m_to_L) + call get_param(param_file, mdl, "MIN_BASAL_TRACTION", CS%min_basal_traction, & + "min. allowed basal traction. Input is in [Pa m-1 yr], but is converted when read in to [Pa m-1 s]", & + units="Pa m-1 yr", default=0., scale=365.0*86400.0*US%Pa_to_RLZ_T2*US%L_T_to_m_s) + call get_param(param_file, mdl, "MAX_SURFACE_SLOPE", CS%max_surface_slope, & + "max. allowed ice-sheet surface slope. To ignore, set to zero.", & + units="none", default=0., scale=US%m_to_Z/US%m_to_L) + call get_param(param_file, mdl, "MIN_ICE_VISC", CS%min_ice_visc, & + "min. allowed Glen's law ice viscosity", & + units="Pa s", default=0., scale=US%Pa_to_RL2_T2*US%s_to_T) + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & units="none", default=3.) @@ -784,6 +809,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_sx_shelf = register_diag_field('ice_shelf_model','sx_shelf',CS%diag%axesB1, Time, & + 'x-surface slope of ice', 'none') + CS%id_sy_shelf = register_diag_field('ice_shelf_model','sy_shelf',CS%diag%axesB1, Time, & + 'y-surface slope of ice', 'none') CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & @@ -837,7 +866,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * ISS%h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -937,26 +966,48 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, calve_ice_shelf_ber end subroutine update_ice_shelf -subroutine volume_above_floatation(CS, G, ISS, vaf) +subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state real, intent(out) :: vaf !< area integrated volume above floatation [m3] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + integer :: IS_ID ! local copy of hemisphere real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [m3] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated integer :: is,ie,js,je,i,j real :: rhoi_rhow, rhow_rhoi if (CS%GL_couple) & call MOM_error(FATAL, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..") - vaf_cell(:,:)=0.0 rhoi_rhow = CS%density_ice / CS%density_ocean_avg rhow_rhoi = CS%density_ocean_avg / CS%density_ice is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (present(hemisphere)) then + IS_ID=hemisphere + else + IS_ID=-1 + endif + + mask(:,:)=0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = js,je; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = js,je; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo; enddo + else !All ice sheets + mask(is:ie,js:je)=ISS%hmask(is:ie,js:je) + endif + + vaf_cell(:,:)=0.0 do j = js,je; do i = is,ie - if (ISS%hmask(i,j)>0) then + if (mask(i,j)>0) then if (CS%bed_elev(i,j) <= 0) then !grounded above sea level vaf_cell(i,j)= (ISS%h_shelf(i,j) * G%US%Z_to_m) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) @@ -1007,6 +1058,8 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, G) taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif + if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag) + if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag) if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) @@ -1328,7 +1381,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (.not. CS%GL_couple) then do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) > 0) then CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif @@ -1346,7 +1399,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%GL_regularize) then - call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) do j=G%jsc,G%jec ; do i=G%isc,G%iec nodefloat = 0 @@ -2263,7 +2316,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - + real :: scale ! Scaling factor used to ensure surface slope magnitude does not exceed CS%max_surface_slope 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 @@ -2289,17 +2342,17 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (CS%GL_couple) then do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo - S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + ISS%h_shelf(i,j)) + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + max(ISS%h_shelf(i,j),CS%min_h_shelf)) enddo enddo else ! check whether the ice is floating or grounded do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then - S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*max(ISS%h_shelf(i,j),CS%min_h_shelf) else - S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) + S(i,j) = max(ISS%h_shelf(i,j),CS%min_h_shelf)-CS%bed_elev(i,j) endif enddo enddo @@ -2393,14 +2446,21 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif endif - sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sx)) - sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sy)) + if (CS%max_surface_slope>0) then + scale = min(CS%max_surface_slope/sqrt((sx**2)+(sy**2)),1.0) + sx = scale*sx; sy = scale*sy + endif + + sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sx)) + sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sy)) + + CS%sx_shelf(i,j) = sx ; CS%sy_shelf(i,j) = sy !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then - neumann_val = ((.5 * grav) * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) + neumann_val = ((.5 * grav) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2 - rhow * CS%bed_elev(i,j)**2)) else - neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * ISS%h_shelf(i,j)**2)) + neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2)) endif if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (CS%reentrant_x .OR. (i+i_off /= gisc)))) then @@ -2996,10 +3056,14 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then if (trim(CS%ice_viscosity_compute) == "CONSTANT") then - CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * & + (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) ! constant viscocity for debugging elseif (trim(CS%ice_viscosity_compute) == "OBS") then - if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j,1) = CS%AGlen_visc(i,j) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + if (CS%AGlen_visc(i,j) >0) then + CS%ice_visc(i,j,1) = max(CS%AGlen_visc(i,j) * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)),& + CS%min_ice_visc) + endif ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file elseif (model_qp1) then !calculate viscosity at 1 cell-centered quadrature point per cell @@ -3027,9 +3091,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & v_shlf(I,J-1) * CS%PhiC(4,i,j)) - CS%ice_visc(i,j,1) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + CS%ice_visc(i,j,1) = max(0.5 * Visc_coef * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & - (US%Pa_to_RL2_T2*US%s_to_T) + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) elseif (model_qp4) then !calculate viscosity at 4 quadrature points per cell @@ -3057,9 +3121,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) - CS%ice_visc(i,j,2*(jq-1)+iq) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + CS%ice_visc(i,j,2*(jq-1)+iq) = max(0.5 * Visc_coef * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & - (US%Pa_to_RL2_T2*US%s_to_T) + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) enddo; enddo endif endif @@ -3123,7 +3187,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) if (CS%CoulombFriction) then !Effective pressure Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) - fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (ISS%h_shelf(i,j) - Hf)),CS%CF_MinN) + fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)),CS%CF_MinN) fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & @@ -3134,6 +3198,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & (US%Pa_to_RLZ_T2*US%L_T_to_m_s) endif + + CS%basal_traction(i,j)=max(CS%basal_traction(i,j), CS%min_basal_traction * G%areaT(i,j)) endif enddo enddo @@ -3194,7 +3260,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -3640,7 +3706,7 @@ end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, !! subject to a mask. -subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. @@ -3650,6 +3716,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. + real, intent(in) :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc real :: h_arr(2,2) @@ -3666,7 +3733,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) num_h = 0 do l=1,2; jc=j-1+l; do k=1,2; ic=i-1+k if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then - h_arr(k,l)=h_shelf(ic,jc) + h_arr(k,l)=max(h_shelf(ic,jc),min_h_shelf) num_h = num_h + 1 else h_arr(k,l)=0.0 From df2cd1265006eb2e98cd9471a8f77c6d8a1c1135 Mon Sep 17 00:00:00 2001 From: Elizabeth Yankovsky Date: Fri, 27 Sep 2024 14:00:08 -0400 Subject: [PATCH 102/128] EBT Backscatter (#706) * EBT Backscatter Backscatter code using the equivalent barotropic (EBT) mode documented in Yankovsky et al. (2024). * Modifications to MOM_hor_visc: - Separate FrictWork and FrictWork_bh loops - Simplified the computation for MEKE%mom_src and MEKE%mom_src_bh when MEKE%backscatter_Ro_c /= 0. (cherry picked from commit 8ffc6a8b9b23de54d782831e419eae3872c11ac6) --------- Co-authored-by: Wenda Zhang Co-authored-by: Marshall Ward --- src/parameterizations/lateral/MOM_MEKE.F90 | 149 +++++-- .../lateral/MOM_MEKE_types.F90 | 2 + .../lateral/MOM_hor_visc.F90 | 367 +++++++++++++++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 26 +- 4 files changed, 460 insertions(+), 84 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 08f24f3a5c..9ebe8ae734 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -55,6 +55,7 @@ module MOM_MEKE logical :: initialized = .false. !< True if this control structure has been initialized. ! Parameters real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] + real :: MEKE_bhFrCoeff!< Efficiency of conversion of ME into MEKE by the biharmonic dissipation [nondim] real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [T-1 ~> s-1]. @@ -126,8 +127,10 @@ module MOM_MEKE type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 + integer :: id_src_adv = -1, id_src_mom_K4 = -1, id_src_btm_drag = -1 + integer :: id_src_GM = -1, id_src_mom_lp = -1, id_src_mom_bh = -1 integer :: id_Ub = -1, id_Ut = -1 - integer :: id_GM_src = -1, id_mom_src = -1, id_GME_snk = -1, id_decay = -1 + integer :: id_GM_src = -1, id_mom_src = -1, id_mom_src_bh = -1, id_GME_snk = -1, id_decay = -1 integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 @@ -192,6 +195,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. + src_adv, & ! The MEKE source/tendency from the horizontal advection of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_K4, & ! The MEKE source/tendency from the bihamornic of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_btm_drag, & ! The MEKE source/tendency from the bottom drag acting on MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_GM, & ! The MEKE source/tendency from the thickness mixing (GM) [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_lp, & ! The MEKE source/tendency from the Laplacian of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_bh, & ! The MEKE source/tendency from the biharmonic of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + damp_rate_s1, & ! The MEKE damping rate computed at the 1st Strang splitting stage [T-1 ~> s-1]. + MEKE_current, & ! A copy of MEKE for use in computing the MEKE damping [L2 T-2 ~> m2 s-2]. drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. @@ -222,9 +233,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. - real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). + real :: damp_step ! Size of damping timestep relative to sdt [nondim] + real :: damp_rate ! The MEKE damping rate [T-1 ~> s-1]. + real :: damping ! The net damping of a field after sdt_damp [nondim] logical :: use_drag_rate ! Flag to indicate drag_rate is finite integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features @@ -254,6 +267,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (allocated(MEKE%mom_src)) & call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%mom_src_bh)) & + call hchksum(MEKE%mom_src_bh, 'MEKE mom_src_bh', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GME_snk)) & call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GM_src)) & @@ -272,7 +287,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! With a depth-dependent (and possibly strong) damping, it seems ! advisable to use Strang splitting between the damping and diffusion. - sdt_damp = sdt ; if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.) sdt_damp = 0.5*sdt + damp_step = 1. + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) damp_step = 0.5 + sdt_damp = sdt * damp_step ! Calculate depth integrated mass exchange if doing advection [R Z L2 ~> kg] if (CS%MEKE_advection_factor>0.) then @@ -387,12 +404,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = CS%MEKE_BGsrc + src_adv(i,j) = 0. + src_mom_K4(i,j) = 0. + src_btm_drag(i,j) = 0. + src_GM(i,j) = 0. + src_mom_lp(i,j) = 0. + src_mom_bh(i,j) = 0. enddo ; enddo if (allocated(MEKE%mom_src)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) & + - (CS%MEKE_bhFrCoeff-CS%MEKE_FrCoeff)*I_mass(i,j)*MEKE%mom_src_bh(i,j) + src_mom_lp(i,j) = - CS%MEKE_FrCoeff*I_mass(i,j)*(MEKE%mom_src(i,j)-MEKE%mom_src_bh(i,j)) + src_mom_bh(i,j) = - CS%MEKE_bhFrCoeff*I_mass(i,j)*MEKE%mom_src_bh(i,j) enddo ; enddo endif @@ -414,6 +440,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + src_GM(i,j) = -CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo endif endif @@ -433,6 +460,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Increase EKE by a full time-steps worth of source !$OMP parallel do default(shared) do j=js,je ; do i=is,ie + MEKE_current(i,j) = MEKE%MEKE(i,j) MEKE%MEKE(i,j) = (MEKE%MEKE(i,j) + sdt*src(i,j))*G%mask2dT(i,j) enddo ; enddo @@ -453,12 +481,29 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! First stage of Strang splitting !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. + damp_rate = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + if (MEKE%MEKE(i,j) < 0.) damp_rate = 0. ! notice that the above line ensures a damping only if MEKE is positive, ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) + + damping = 1. / (1. + sdt_damp * damp_rate) + + ! NOTE: MEKE%MEKE should use `damping` but we must preserve the existing + ! expression for bit reproducibility + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate) + MEKE_decay(i,j) = damp_rate * G%mask2dT(i,j) + + src_GM(i,j) = src_GM(i,j) * damping + src_mom_lp(i,j) = src_mom_lp(i,j) * damping + src_mom_bh(i,j) = src_mom_bh(i,j) * damping + + src_btm_drag(i,j) = - MEKE_current(i,j) * ( & + damp_step * (damp_rate * damping) & + ) + + ! Store the effective damping rate if sdt is split + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) & + damp_rate_s1(i,j) = damp_rate * damping enddo ; enddo if (CS%kh_flux_enabled .or. CS%MEKE_K4 >= 0.0) then @@ -528,6 +573,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + src_mom_K4(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo endif ! @@ -595,6 +643,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + src_adv(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo endif ! MEKE_KH>0 @@ -608,25 +659,38 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Second stage of Strang splitting if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.0) then - if (sdt>sdt_damp) then - ! Recalculate the drag rate, since MEKE has changed. - if (use_drag_rate) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & - cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) - enddo ; enddo - endif + ! Recalculate the drag rate, since MEKE has changed. + if (use_drag_rate) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. - ! notice that the above line ensures a damping only if MEKE is positive, - ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + if (MEKE%MEKE(i,j) < 0.) damp_rate = 0. + ! notice that the above line ensures a damping only if MEKE is positive, + ! while leaving MEKE unchanged if it is negative + + damping = 1. / (1. + sdt_damp * damp_rate) + + ! NOTE: As above, MEKE%MEKE should use `damping` but we must preserve + ! the existing expression for bit reproducibility. + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*damp_rate) + MEKE_decay(i,j) = damp_rate*G%mask2dT(i,j) + + src_GM(i,j) = src_GM(i,j) * damping + src_mom_lp(i,j) = src_mom_lp(i,j) * damping + src_mom_bh(i,j) = src_mom_bh(i,j) * damping + src_adv(i,j) = src_adv(i,j) * damping + src_mom_K4(i,j) = src_mom_K4(i,j) * damping + + src_btm_drag(i,j) = -MEKE_current(i,j) * ( & + damp_step * damping * (damp_rate + damp_rate_s1(i,j)) & + ) + enddo ; enddo endif ! MEKE_KH>=0 if (CS%debug) then @@ -727,9 +791,16 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%id_KhMEKE_u>0) call post_data(CS%id_KhMEKE_u, Kh_u, CS%diag) if (CS%id_KhMEKE_v>0) call post_data(CS%id_KhMEKE_v, Kh_v, CS%diag) if (CS%id_src>0) call post_data(CS%id_src, src, CS%diag) + if (CS%id_src_adv>0) call post_data(CS%id_src_adv, src_adv, CS%diag) + if (CS%id_src_mom_K4>0) call post_data(CS%id_src_mom_K4, src_mom_K4, CS%diag) + if (CS%id_src_btm_drag>0) call post_data(CS%id_src_btm_drag, src_btm_drag, CS%diag) + if (CS%id_src_GM>0) call post_data(CS%id_src_GM, src_GM, CS%diag) + if (CS%id_src_mom_lp>0) call post_data(CS%id_src_mom_lp, src_mom_lp, CS%diag) + if (CS%id_src_mom_bh>0) call post_data(CS%id_src_mom_bh, src_mom_bh, CS%diag) if (CS%id_decay>0) call post_data(CS%id_decay, MEKE_decay, CS%diag) if (CS%id_GM_src>0) call post_data(CS%id_GM_src, MEKE%GM_src, CS%diag) if (CS%id_mom_src>0) call post_data(CS%id_mom_src, MEKE%mom_src, CS%diag) + if (CS%id_mom_src_bh>0) call post_data(CS%id_mom_src_bh, MEKE%mom_src_bh, CS%diag) if (CS%id_GME_snk>0) call post_data(CS%id_GME_snk, MEKE%GME_snk, CS%diag) if (CS%id_Le>0) call post_data(CS%id_Le, LmixScale, CS%diag) if (CS%id_gamma_b>0) then @@ -1210,6 +1281,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "The efficiency of the conversion of mean energy into "//& "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_BHFRCOEFF", CS%MEKE_bhFrCoeff, & + "The efficiency of the conversion of mean energy into "//& + "MEKE by the biharmonic dissipation. If MEKE_bhFRCOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & "The efficiency of the conversion of MEKE into mean energy "//& "by GME. If MEKE_GMECOEFF is negative, this conversion "//& @@ -1399,6 +1474,20 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (.not. allocated(MEKE%MEKE)) CS%id_Ut = -1 CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + !add diagnostics for the terms in the MEKE budget + CS%id_src_adv = register_diag_field('ocean_model', 'MEKE_src_adv', diag%axesT1, Time, & + 'MEKE energy source from the horizontal advection of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_mom_K4 = register_diag_field('ocean_model', 'MEKE_src_mom_K4', diag%axesT1, Time, & + 'MEKE energy source from the biharmonic of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_btm_drag = register_diag_field('ocean_model', 'MEKE_src_btm_drag', diag%axesT1, Time, & + 'MEKE energy source from the bottom drag acting on MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_GM = register_diag_field('ocean_model', 'MEKE_src_GM', diag%axesT1, Time, & + 'MEKE energy source from the thickness mixing (GM scheme)', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_mom_lp = register_diag_field('ocean_model', 'MEKE_src_mom_lp', diag%axesT1, Time, & + 'MEKE energy source from the Laplacian of resolved flows', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_mom_bh = register_diag_field('ocean_model', 'MEKE_src_mom_bh', diag%axesT1, Time, & + 'MEKE energy source from the biharmonic of resolved flows', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + !end CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & @@ -1409,6 +1498,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME 'MEKE energy available from momentum', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. allocated(MEKE%mom_src)) CS%id_mom_src = -1 + CS%id_mom_src_bh = register_diag_field('ocean_model', 'MEKE_mom_src_bh',diag%axesT1, Time, & + 'MEKE energy available from the biharmonic dissipation of momentum', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%mom_src_bh)) CS%id_mom_src_bh = -1 CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & 'MEKE energy lost to GME backscatter', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) @@ -1742,7 +1835,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables - real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_bhFrCoeff, 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 @@ -1754,6 +1847,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) ! 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_bhFrCoeff = -1. ; call read_param(param_file,"MEKE_bhFRCOEFF",MEKE_bhFrCoeff) 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) @@ -1770,8 +1864,12 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, 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.) & + if (MEKE_FrCoeff>=0. .or. MEKE_bhFrCoeff>=0. .or. MEKE_GMECoeff>=0.) then allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) + allocate(MEKE%mom_src_bh(isd:ied,jsd:jed), source=0.0) + endif + if (MEKE_FrCoeff<0.) MEKE_FrCoeff = 0. + if (MEKE_bhFrCoeff<0.) MEKE_bhFrCoeff = 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) @@ -1817,6 +1915,7 @@ subroutine MEKE_end(MEKE) if (allocated(MEKE%Kh)) deallocate(MEKE%Kh) if (allocated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) if (allocated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (allocated(MEKE%mom_src_bh)) deallocate(MEKE%mom_src_bh) if (allocated(MEKE%GM_src)) deallocate(MEKE%GM_src) if (allocated(MEKE%MEKE)) deallocate(MEKE%MEKE) end subroutine MEKE_end diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index e51f558ce3..a95578848d 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -11,6 +11,8 @@ module MOM_MEKE_types real, allocatable :: GM_src(:,:) !< MEKE source due to thickness mixing (GM) [R Z L2 T-3 ~> W m-2]. real, allocatable :: mom_src(:,:) !< MEKE source from lateral friction in the !! momentum equations [R Z L2 T-3 ~> W m-2]. + real, allocatable :: mom_src_bh(:,:) !< MEKE source from the biharmonic part of the lateral friction in the + !! momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: GME_snk(:,:) !< MEKE sink from GME backscatter in the momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: Kh(:,:) !< The MEKE-derived lateral mixing coefficient [L2 T-1 ~> m2 s-1]. real, allocatable :: Kh_diff(:,:) !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 52a9bbefe1..56a359857f 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -50,6 +50,9 @@ module MOM_hor_visc !! limited to guarantee stability. logical :: better_bound_Kh !< If true, use a more careful bounding of the !! Laplacian viscosity to guarantee stability. + logical :: EY24_EBT_BS !! If true, use an equivalent barotropic backscatter + !! with a stabilizing kill switch in MEKE, + !< developed by Yankovsky et al. 2024 logical :: bound_Ah !< If true, the biharmonic coefficient is locally !! limited to guarantee stability. logical :: better_bound_Ah !< If true, use a more careful bounding of the @@ -60,6 +63,9 @@ module MOM_hor_visc !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. !! The default is 0.8. + real :: KS_coef !< A nondimensional coefficient on the biharmonic viscosity that sets the + !! kill switch for backscatter. Default is 1.0 [nondim]. + real :: KS_timescale !< A timescale for computing CFL limit for turning off backscatter [T ~> s]. logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed !! to increase where the Laplacian viscosity is negative (due to !! backscatter parameterizations) beyond the largest timestep-dependent @@ -145,6 +151,7 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + Ah_Max_xx_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] @@ -163,6 +170,7 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + Ah_Max_xy_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] @@ -230,8 +238,13 @@ module MOM_hor_visc 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 + integer :: id_FrictWork_bh = -1, id_FrictWorkIntz_bh = -1 integer :: id_FrictWork_GME = -1 integer :: id_normstress = -1, id_shearstress = -1 + integer :: id_visc_limit_h = -1, id_visc_limit_q = -1 + integer :: id_visc_limit_h_flag = -1, id_visc_limit_q_flag = -1 + integer :: id_visc_limit_h_frac = -1, id_visc_limit_q_frac = -1 + integer :: id_BS_coeff_h = -1, id_BS_coeff_q = -1 !>@} end type hor_visc_CS @@ -313,6 +326,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] + FrictWorkIntz_bh, & ! depth integrated energy dissipated by biharmonic 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] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] @@ -321,7 +335,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] m_leithy, & ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] Ah_sq, & ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2] - htot ! The total thickness of all layers [H ~> m or kg m-2] + htot, & ! The total thickness of all layers [H ~> m or kg m-2] + str_xx_BS ! The diagonal term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] @@ -346,7 +361,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] ! This form guarantees that hq/hu < 4. - GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] + str_xy_BS ! The cross term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] 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] @@ -356,6 +372,10 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] + visc_limit_q, & ! used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_q_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_q_frac, & ! determines how close backscatter is to shutting off [nondim] + BS_coeff_q, & ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u_GME, & !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] @@ -368,14 +388,19 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] dz, & ! Height change across layers [Z ~> m] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWork_bh, & ! work done by the biharmonic MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - NoSt ! A diagnostic array of normal stress [T-1 ~> s-1]. + NoSt, & ! A diagnostic array of normal stress [T-1 ~> s-1]. + BS_coeff_h ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] - GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + GME_coeff_h, & ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + visc_limit_h, & ! Used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_h_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_h_frac ! determines how close backscatter is to shutting off [nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & @@ -426,6 +451,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] + real :: tmp ! Fields evaluated on active layers, used for constructing 3D stress fields ! NOTE: The position of these declarations can impact performance, due to the @@ -436,6 +462,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, real, dimension(SZIB_(G),SZJB_(G)) :: & Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] + Kh_BS, & ! Laplacian antiviscosity [L2 T-1 ~> m2 s-1] Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] @@ -452,6 +479,13 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + visc_limit_h(:,:,:) = 0. + visc_limit_q(:,:,:) = 0. + visc_limit_h_flag(:,:,:) = 0. + visc_limit_q_flag(:,:,:) = 0. + visc_limit_h_frac(:,:,:) = 0. + visc_limit_q_frac(:,:,:) = 0. + m_leithy(:,:) = 0.0 ! Initialize if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then @@ -633,12 +667,12 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & - !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_bh, 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, hu_cont, hv_cont & !$OMP ) & !$OMP private( & - !$OMP i, j, k, n, & + !$OMP i, j, k, n, tmp, & !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, & !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, & !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & @@ -654,7 +688,12 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & !$OMP sh_xx_smooth, sh_xy_smooth, & - !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy & + !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy, & + !$OMP Kh_BS, str_xx_bs, str_xy_bs, bs_coeff_h, bs_coeff_q & + !$OMP ) & + !$OMP firstprivate( & + !$OMP visc_limit_h, visc_limit_h_frac, visc_limit_h_flag, & + !$OMP visc_limit_q, visc_limit_q_frac, visc_limit_q_flag & !$OMP ) do k=1,nz @@ -1140,15 +1179,15 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) enddo ; enddo - if (use_MEKE_Ku) then + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (which might be negative) if (CS%res_scale_MEKE) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k) enddo ; enddo else do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) enddo ; enddo endif endif @@ -1350,6 +1389,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif endif + if (CS%EY24_EBT_BS) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + tmp = CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j) + visc_limit_h(i,j,k) = tmp + visc_limit_h_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j)) + if (Ah(i,j) >= tmp) then + visc_limit_h_flag(i,j,k) = 1. + endif + enddo ; enddo + endif + if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah_h(i,j,k) = Ah(i,j) @@ -1365,7 +1415,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif - if (CS%id_grid_Re_Ah>0) then + if (CS%id_grid_Re_Ah > 0) then do j=js,je ; do i=is,ie KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))**2) + ((v(i,J,k) + v(i,J-1,k))**2)) grid_Ah = max(Ah(i,j), CS%min_grid_Ah) @@ -1387,6 +1437,31 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (visc_limit_h_flag(i,j,k) > 0) then + Kh_BS(i,j) = 0. + else + Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + endif + enddo ; enddo + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx_BS(i,j) = -Kh_BS(i,j) * sh_xx(i,j) + enddo ; enddo + + if (CS%id_BS_coeff_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + BS_coeff_h(i,j,k) = Kh_BS(i,j) + enddo ; enddo + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = str_xx(i,j) + str_xx_BS(i,j) + enddo ; enddo + endif ! Backscatter + if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term do J=js-1,Jeq ; do I=is-1,Ieq @@ -1541,10 +1616,12 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, Kh(I,J) = max(Kh(I,J), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. - if (use_MEKE_Ku) then + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (might be negative) - Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & - (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn + Kh(I,J) = Kh(I,J) + 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) * meke_res_fn endif if (CS%anisotropic) & @@ -1671,6 +1748,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif endif + if (CS%EY24_EBT_BS) then + do J=js-1,Jeq ; do I=is-1,Ieq + tmp = CS%KS_coef *hrat_min(I,J) * CS%Ah_Max_xy_KS(I,J) + visc_limit_q(I,J,k) = tmp + visc_limit_q_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xy_KS(i,j)) + if (Ah(I,J) >= tmp) then + visc_limit_q_flag(I,J,k) = 1. + endif + enddo ; enddo + endif + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points if (CS%use_Leithy) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1695,6 +1783,34 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif ! Get Ah at q points and biharmonic part of str_xy + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (visc_limit_q_flag(I,J,k) > 0) then + Kh_BS(I,J) = 0. + else + Kh_BS(I,J) = 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) + endif + enddo ; enddo + + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy_BS(I,J) = -Kh_BS(I,J) * (sh_xy(I,J)) + enddo ; enddo + + if (CS%id_BS_coeff_q>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + BS_coeff_q(I,J,k) = Kh_BS(I,J) + enddo ; enddo + endif + + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = str_xy(I,J) + str_xy_BS(I,J) + enddo ; enddo + endif ! Backscatter + 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 @@ -1795,34 +1911,42 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif if (find_FrictWork) then - if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie - ! 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)))) ) ) ) + if (CS%FrictWork_bug) then + do j=js,je ; do i=is,ie + ! 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 + if (visc_limit_h_flag(i,j,k) > 0) then + FrictWork(i,j,k) = 0 + else + 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)))) ) ) ) + endif enddo ; enddo else ; do j=js,je ; do i=is,ie - FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + if (visc_limit_h_flag(i,j,k) > 0) then + FrictWork(i,j,k) = 0 + else + FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & ((str_xx(i,j)*CS%dy2h(i,j) * ( & (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & - (str_xx(i,j)*CS%dx2h(i,j) * ( & (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & - + (0.25*(((str_xy(I,J)*( & + + (0.25*(((str_xy(I,J)*( & (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & @@ -1842,10 +1966,75 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + + endif + enddo ; enddo ; endif + endif + + if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie + ! 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 + if (visc_limit_h_flag(i,j,k) > 0) then + FrictWork_bh(i,j,k) = 0 + else + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion !cyc + FrictWork_bh(i,j,k) = GV%H_to_RZ * ( & + (bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((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)) & + + 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)) ) & + + (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)) & + + 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)) ) ) ) + endif + enddo ; enddo + else ; do j=js,je ; do i=is,ie + if (visc_limit_h_flag(i,j,k) > 0) then + FrictWork_bh(i,j,k) = 0 + else + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + FrictWork_bh(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((bhstr_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (bhstr_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((bhstr_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(bhstr_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((bhstr_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(bhstr_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + endif enddo ; enddo ; endif endif + if (CS%use_GME) then if (CS%FrictWork_bug) 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) @@ -1905,6 +2094,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (k==1) then do j=js,je ; do i=is,ie MEKE%mom_src(i,j) = 0. + MEKE%mom_src_bh(i,j) = 0. enddo ; enddo if (allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie @@ -1937,27 +2127,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & - (((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & - - ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & - + 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)))) ) ) ) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (FrictWork(i,j,k) - RoScl*FrictWork_bh(i,j,k)) + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + & + (FrictWork_bh(i,j,k) - RoScl*FrictWork_bh(i,j,k)) enddo ; enddo - endif ! MEKE%backscatter_Ro_c + else do j=js,je ; do i=is,ie MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k) enddo ; enddo + endif ! MEKE%backscatter_Ro_c if (CS%use_GME .and. allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie @@ -1975,6 +2155,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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_bh>0) call post_data(CS%id_FrictWork_bh, FrictWork_bh, 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) @@ -1994,6 +2175,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag) + if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag) + if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag) + if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) + if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) + if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) + + if (CS%EY24_EBT_BS) then + if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) + if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) + endif if (CS%debug) then if (CS%Laplacian) then @@ -2014,6 +2206,16 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + if (CS%id_FrictWorkIntz_bh > 0) then + do j=js,je + do i=is,ie ; FrictWorkIntz_bh(i,j) = FrictWork_bh(i,j,1) ; enddo + do k=2,nz ; do i=is,ie + FrictWorkIntz_bh(i,j) = FrictWorkIntz_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + enddo + call post_data(CS%id_FrictWorkIntz_bh, FrictWorkIntz_bh, CS%diag) + endif + if (present(ADp)) then ! Diagnostics of the fractional thicknesses times momentum budget terms ! 3D diagnostics of hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. @@ -2206,8 +2408,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, the Laplacian coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_KH.", & default=CS%bound_Kh, do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "EY24_EBT_BS", CS%EY24_EBT_BS, & + "If true, use the the backscatter scheme (EBT mode with kill switch)"//& + "developed by Yankovsky et al. (2024). ", & + default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%bound_Kh = .false. if (.not.CS%Laplacian) CS%better_bound_Kh = .false. + if (.not.(CS%Laplacian.and.use_MEKE)) CS%EY24_EBT_BS = .false. call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false., & @@ -2358,6 +2565,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8, do_not_log=.not.(CS%better_bound_Ah .or. CS%better_bound_Kh)) + call get_param(param_file, mdl, "KILL_SWITCH_COEF", CS%KS_coef, & + "A nondimensional coefficient on the biharmonic viscosity that "// & + "sets the kill switch for backscatter. Default is 1.0.", units="nondim", & + default=1.0, do_not_log=.not.(CS%EY24_EBT_BS)) call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -2423,6 +2634,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) fail_if_missing=.true.) Idt = 1.0 / dt endif + call get_param(param_file, mdl, "KILL_SWITCH_TIMESCALE", CS%KS_timescale, & + "A timescale for computing the CFL limit for viscosity "// & + "that determines when backscatter is shut off. Default is DT.", & + default= dt , units="s", scale=US%s_to_T, do_not_log=.not.(CS%EY24_EBT_BS)) + if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") @@ -2446,11 +2662,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 - if (CS%bound_Kh .or. CS%better_bound_Kh) then + if (CS%bound_Kh .or. CS%better_bound_Kh .or. CS%EY24_EBT_BS) then ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 endif - if (CS%Smagorinsky_Kh) then + if (CS%Smagorinsky_Kh .or. CS%EY24_EBT_BS) then ALLOC_(CS%Laplac2_const_xx(isd:ied,jsd:jed)) ; CS%Laplac2_const_xx(:,:) = 0.0 ALLOC_(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac2_const_xy(:,:) = 0.0 endif @@ -2508,6 +2724,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 endif + if (CS%EY24_EBT_BS) then + ALLOC_(CS%Ah_Max_xx_KS(isd:ied,jsd:jed)) ; CS%Ah_Max_xx_KS(:,:) = 0.0 + ALLOC_(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy_KS(:,:) = 0.0 + endif if (CS%Smagorinsky_Ah) then ALLOC_(CS%Biharm_const_xx(isd:ied,jsd:jed)) ; CS%Biharm_const_xx(:,:) = 0.0 ALLOC_(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const_xy(:,:) = 0.0 @@ -2766,8 +2986,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0v(i,J)) + (G%IdxCv(i,J-1)*v0v(i,J-1))))) * & max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) ) CS%Ah_Max_xx(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xx_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq denom = max( & @@ -2780,8 +3005,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (CS%DY_dxBu(I,J)*((v0v(i+1,J)*G%IdyCv(i+1,J)) + (v0v(i,J)*G%IdyCv(i,J))))) * & max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) ) CS%Ah_Max_xy(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xy_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo if (CS%debug) then call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) @@ -2880,6 +3110,18 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') + CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim') + CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim') + CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') if (CS%id_grid_Re_Ah > 0) & ! Compute the smallest biharmonic viscosity capable of modifying the @@ -2931,6 +3173,14 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) '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 + + if (CS%EY24_EBT_BS) then + CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, & + 'Backscatter coefficient at h points', 'm2 s-1') + CS%id_BS_coeff_q = register_diag_field('ocean_model', 'BS_coeff_q', diag%axesBL, Time, & + 'Backscatter coefficient at q points', 'm2 s-1') + 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 '//& 'includes the GME contribution.', & @@ -2941,6 +3191,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') + CS%id_FrictWork_bh = register_diag_field('ocean_model','FrictWork_bh',diag%axesTL,Time,& + 'Integral work done by the biharmonic lateral friction terms.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWorkIntz_bh = register_diag_field('ocean_model','FrictWorkIntz_bh',diag%axesT1,Time,& + 'Depth integrated work done by the biharmonic lateral friction', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) end subroutine hor_visc_init @@ -3171,6 +3427,9 @@ subroutine hor_visc_end(CS) if (CS%bound_Ah) then DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif + if (CS%EY24_EBT_BS) then + DEALLOC_(CS%Ah_Max_xx_KS) ; DEALLOC_(CS%Ah_Max_xy_KS) + endif if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7ff7f187fc..e3979fe35a 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -113,6 +113,9 @@ module MOM_lateral_mixing_coeffs real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [Z L-1 ~> nondim] real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [Z L-1 ~> nondim] real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] + real, allocatable :: BS_struct(:,:,:) !< Vertical structure function used in backscatter [nondim] + real :: BS_EBT_power !< Power to raise EBT vertical structure to. Default 0.0. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] @@ -228,7 +231,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 + integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -238,7 +241,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%calculate_cg1) then if (.not. allocated(CS%cg1)) call MOM_error(FATAL, & "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") - if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0.) then if (.not. allocated(CS%ebt_struct)) call MOM_error(FATAL, & "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then @@ -258,6 +261,11 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif + if (CS%BS_EBT_power>0.) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%ebt_struct(i,j,k)**CS%BS_EBT_power + enddo ; enddo ; enddo + endif ! Calculate and store the ratio between deformation radius and grid-spacing ! at h-points [nondim]. @@ -1249,6 +1257,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, uses the equivalent barotropic wave speed instead "//& "of first baroclinic wave for calculating the resolution fn.",& default=.false.) + call get_param(param_file, mdl, "BACKSCAT_EBT_POWER", CS%BS_EBT_power, & + "Power to raise EBT vertical structure to when backscatter "// & + "has vertical structure.", units="nondim", default=0.0) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& @@ -1274,7 +1285,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=1.0e-17, units="s-1", scale=US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & default=.false., do_not_log=.true.) - CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct & + .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0. CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) @@ -1298,7 +1310,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") endif - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%BS_EBT_power>0.) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& @@ -1307,6 +1320,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif + allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + CS%BS_struct(:,:,:) = 1.0 if (CS%use_stored_slopes) then if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then @@ -1655,8 +1670,9 @@ end subroutine VarMix_init subroutine VarMix_end(CS) type(VarMix_CS), intent(inout) :: CS - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) & + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0.) & deallocate(CS%ebt_struct) + if (allocated(CS%BS_struct)) deallocate(CS%BS_struct) if (CS%use_stored_slopes) then deallocate(CS%slope_x) From e24cd3aa1ae91685c69238d7b94f457186c72aec Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 27 Sep 2024 10:08:38 -0400 Subject: [PATCH 103/128] change CMOR names, fixes #709 bigthetao refers the the uppercase greek letter theta used for conservative temperature. Salinity so uses the roman alphabet and a bigso is ambiguous as many papers use S for salinity hence absso seems like the most unambiguous. --- src/core/MOM.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 47971029cc..e6cd3cf747 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2706,7 +2706,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tv%T => CS%T ; CS%tv%S => CS%S if (CS%tv%T_is_conT) then vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & - cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & + cmor_field_name="bigthetao", cmor_longname="Sea Water Conservative Temperature", & conversion=US%Q_to_J_kg*CS%tv%C_p) else vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & @@ -2715,7 +2715,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (CS%tv%S_is_absS) then vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & - cmor_field_name="so", cmor_longname="Sea Water Salinity", & + cmor_field_name="absso", cmor_longname="Sea Water Absolute Salinity", & conversion=0.001*US%S_to_ppt) else vd_S = var_desc(name="salt", units="psu", longname="Salinity", & From 5dcc8e0249513da774ccea321143b82ed2bf8949 Mon Sep 17 00:00:00 2001 From: He Wang Date: Sun, 29 Sep 2024 02:38:56 -0400 Subject: [PATCH 104/128] Fix .testing make for regression tests This commit fixes a bug that target code cannot be built for regression tests when BUILD is specified with command line arguments. The fix explicitly specifies BUILD argument for target codebase, avoiding the variable being passed from the parent make. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index adc1a20a1e..18687a1616 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -282,7 +282,7 @@ $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE # Target codebase should use its own build system $(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) - $(MAKE) -C $(TARGET_CODEBASE)/.testing build/symmetric/MOM6 + $(MAKE) -C $(TARGET_CODEBASE)/.testing BUILD=build build/symmetric/MOM6 $(BUILD)/target: | $(TARGET_CODEBASE) ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/symmetric $@ From cfa8a3d08757ffd8806b4199c759100a4b91e3ca Mon Sep 17 00:00:00 2001 From: alex-huth Date: Thu, 19 Sep 2024 18:13:22 -0400 Subject: [PATCH 105/128] New diagnostics for flux divergence, strain-rates, deviatorics stresses, and ice speed; and the magnitude of ice surface slope and driving stress. Fixed some misleading units for variables related to ice viscosity --- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 196 ++++++++++++++++++++--- 2 files changed, 179 insertions(+), 21 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 52b1ebdcea..6e248eb607 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -824,7 +824,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step enddo; enddo - call IS_dynamics_post_data(time_step, Time, CS%dCS, G) + call IS_dynamics_post_data(time_step, Time, CS%dCS, ISS, G) endif if (CS%shelf_mass_is_dynamic) & @@ -2603,7 +2603,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Ifull_time_step, dh_adott, dh_adott*0.0) call disable_averaging(CS%diag) - call IS_dynamics_post_data(full_time_step, Time, CS%dCS, G) + call IS_dynamics_post_data(full_time_step, Time, CS%dCS, ISS, G) end subroutine solo_step_ice_shelf !> Post_data calls for ice-sheet scalars diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 3ed262e5f3..d9c372761d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -89,9 +89,9 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [C ~> degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), - !! in [R L2 T-1 ~> kg m-1 s-1]. - !! at either 1 (cell-centered) or 4 quadrature points per cell + real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Area and depth-integrated Glen's law ice viscosity + !! (Pa m3 s) in [R L4 Z T-1 ~> kg m2 s-1]. + !! at either 1 (cell-centered) or 4 quadrature points per cell real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries @@ -227,11 +227,17 @@ module MOM_ice_shelf_dynamics logical :: module_is_initialized = .false. !< True if this module has been initialized. !>@{ Diagnostic handles - integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & - id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & + integer :: id_u_shelf = -1, id_v_shelf = -1, id_shelf_speed, id_t_shelf = -1, & + id_taudx_shelf = -1, id_taudy_shelf = -1, id_taud_shelf = -1, id_bed_elev = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1, & - id_sx_shelf = -1, id_sy_shelf = -1 + id_sx_shelf = -1, id_sy_shelf = -1, id_surf_slope_mag_shelf, & + id_duHdx = -1, id_dvHdy = -1, id_fluxdiv = -1, & + id_strainrate_xx = -1, id_strainrate_yy = -1, id_strainrate_xy = -1, & + id_pstrainrate_1 = -1, id_pstrainrate_2, & + id_devstress_xx = -1, id_devstress_yy = -1, id_devstress_xy = -1, & + id_pdevstress_1 = -1, id_pdevstress_2 = -1 + !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging @@ -805,14 +811,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) + CS%id_shelf_speed = register_diag_field('ice_shelf_model','shelf_speed',CS%diag%axesB1, Time, & + 'speed of of ice shelf', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_taud_shelf = register_diag_field('ice_shelf_model','taud_shelf',CS%diag%axesB1, Time, & + 'magnitude of driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_sx_shelf = register_diag_field('ice_shelf_model','sx_shelf',CS%diag%axesB1, Time, & 'x-surface slope of ice', 'none') CS%id_sy_shelf = register_diag_field('ice_shelf_model','sy_shelf',CS%diag%axesB1, Time, & 'y-surface slope of ice', 'none') + CS%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model','surf_slope_mag_shelf', CS%diag%axesB1, Time, & + 'magnitude of surface slope of ice', 'none') CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & @@ -830,6 +842,33 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + CS%id_duHdx = register_diag_field('ice_shelf_model','duHdx',CS%diag%axesT1, Time, & + 'x-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_dvHdy = register_diag_field('ice_shelf_model','dvHdy',CS%diag%axesT1, Time, & + 'y-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_fluxdiv = register_diag_field('ice_shelf_model','fluxdiv',CS%diag%axesT1, Time, & + 'ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_strainrate_xx = register_diag_field('ice_shelf_model','strainrate_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_yy = register_diag_field('ice_shelf_model','strainrate_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_xy = register_diag_field('ice_shelf_model','strainrate_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_1 = register_diag_field('ice_shelf_model','pstrainrate_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_2 = register_diag_field('ice_shelf_model','pstrainrate_2',CS%diag%axesT1, Time, & + 'min principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_devstress_xx = register_diag_field('ice_shelf_model','devstress_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_yy = register_diag_field('ice_shelf_model','devstress_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_xy = register_diag_field('ice_shelf_model','devstress_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_1 = register_diag_field('ice_shelf_model','pdevstress_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_2 = register_diag_field('ice_shelf_model','pdevstress_2',CS%diag%axesT1, Time, & + 'min principal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + !Update these variables so that they are nonzero in case !IS_dynamics_post_data is called before update_ice_shelf if (CS%id_taudx_shelf>0 .or. CS%id_taudy_shelf>0) & @@ -1035,10 +1074,12 @@ subroutine masked_var_grounded(G,CS,var,varout) end subroutine masked_var_grounded !> Ice shelf dynamics post_data calls -subroutine IS_dynamics_post_data(time_step, Time, CS, G) +subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) real :: time_step !< Length of time for post data averaging [T ~> s]. type(time_type), intent(in) :: Time !< The current model time type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity @@ -1049,6 +1090,7 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, G) 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_shelf_speed > 0) call post_data(CS%id_shelf_speed, sqrt((CS%u_shelf**2) + (CS%v_shelf**2)), 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%IareaBu(:,:) @@ -1058,8 +1100,15 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, G) taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif + if (CS%id_taud_shelf > 0) then + taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) + call post_data(CS%id_taud_shelf, sqrt((taud_x**2)+(taud_y**2)), CS%diag) + endif if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag) if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag) + if (CS%id_surf_slope_mag_shelf > 0) & + call post_data(CS%id_surf_slope_mag_shelf, sqrt((CS%sx_shelf**2)+(CS%sy_shelf**2)), CS%diag) if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) @@ -1082,6 +1131,14 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, G) 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_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0 .or. & + CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then + call IS_dynamics_post_data_2(CS, ISS, G) + endif + call disable_averaging(CS%diag) end subroutine IS_dynamics_post_data @@ -2540,8 +2597,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice !! shelf is floating: 0 if floating, 1 if not @@ -2817,12 +2873,10 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -3006,6 +3060,108 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd end subroutine CG_diagonal_subgrid_basal +!> Post_data calls related to ice-sheet flux divergence, strain-rate, and deviatoric stress +subroutine IS_dynamics_post_data_2(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hu ! Ice shelf u_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hv ! Ice shelf v_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hux ! Ice shelf d(u_flux)/dx at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hvy ! Ice shelf d(v_flux)/dy at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! 2-D flux divergence div(uH) [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! 2-D strain-rate components xx,yy, and xy [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc_loc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s] + real, dimension(SZDI_(G),SZDJ_(G)) :: p1,p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1] + integer :: i, j + + !Allocate the gradient basis functions for 1 cell-centered quadrature point per cell + if (.not. associated(CS%PhiC)) then + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo; enddo + endif + + !Calculate flux divergence and its components + if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0) then + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) + Hu(:,:) = (H_node(:,:) * CS%u_shelf(:,:)) + Hv(:,:) = (H_node(:,:) * CS%v_shelf(:,:)) + Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !components of flux divergence at cell centers + Hux(i,j) = (((Hu(I-1,J-1) * CS%PhiC(1,i,j)) + (Hu(I,J ) * CS%PhiC(7,i,j))) + & + ((Hu(I-1,J ) * CS%PhiC(5,i,j)) + (Hu(I,J-1) * CS%PhiC(3,i,j)))) + + Hvy(i,j) = (((Hv(I-1,J-1) * CS%PhiC(2,i,j)) + (Hv(I,J ) * CS%PhiC(8,i,j))) + & + ((Hv(I-1,J ) * CS%PhiC(6,i,j)) + (Hv(I,J-1) * CS%PhiC(4,i,j)))) + endif + enddo ; enddo + + if (CS%id_duHdx > 0) call post_data(CS%id_duHdx, Hux, CS%diag) + if (CS%id_dvHdy > 0) call post_data(CS%id_dvHdy, Hvy, CS%diag) + if (CS%id_fluxdiv > 0) call post_data(CS%id_fluxdiv, Hux+Hvy, CS%diag) + endif + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then + + strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !strain-rates at cell centers + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !strain_rate(:,:,1) = strain_rate_xx(:,:) = ux(:,:) + strain_rate(i,j,1) = (((CS%u_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(3,i,j)))) + !strain_rate(:,:,2) = strain_rate_yy(:,:) = uy(:,:) + strain_rate(i,j,2) = (((CS%v_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(4,i,j)))) + !strain_rate(:,:,3) = strain_rate_xy(:,:) = 0.5 * (uy(:,:) + vy(:,:)) + strain_rate(i,j,3) = 0.5 * ((((CS%u_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(4,i,j))))+ & + (((CS%v_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(3,i,j))))) + endif + enddo ; enddo + + + if (CS%id_strainrate_xx > 0) call post_data(CS%id_strainrate_xx, strain_rate(:,:,1), CS%diag) + if (CS%id_strainrate_yy > 0) call post_data(CS%id_strainrate_yy, strain_rate(:,:,2), CS%diag) + if (CS%id_strainrate_xy > 0) call post_data(CS%id_strainrate_xy, strain_rate(:,:,3), CS%diag) + + + if (CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p1(:,:) = 0.5*( strain_rate(:,:,1) + strain_rate(:,:,2)) + p2(:,:) = sqrt( (( 0.5 * (strain_rate(:,:,1) - strain_rate(:,:,2)) )**2) + (strain_rate(:,:,3)**2) ) + endif + + if (CS%id_pstrainrate_1 > 0) call post_data(CS%id_pstrainrate_1, p1+p2, CS%diag) + if (CS%id_pstrainrate_2 > 0) call post_data(CS%id_pstrainrate_2, p1-p2, CS%diag) + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + if (CS%visc_qps==4) then + ice_visc_loc(:,:) = ((0.25 * G%IareaT(:,:)) * & + ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3)))) / ISS%h_shelf(:,:) + else + ice_visc_loc(:,:) = (CS%ice_visc(:,:,1)*G%IareaT(:,:)) / ISS%h_shelf(:,:) + endif + + if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, 2*ice_visc_loc*strain_rate(:,:,1), CS%diag) + if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, 2*ice_visc_loc*strain_rate(:,:,2), CS%diag) + if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, 2*ice_visc_loc*strain_rate(:,:,3), CS%diag) + if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, 2*ice_visc_loc*(p1+p2), CS%diag) + if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, 2*ice_visc_loc*(p1-p2), CS%diag) + endif + endif +end subroutine IS_dynamics_post_data_2 !> Update depth integrated viscosity, based on horizontal strain rates subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) @@ -3061,8 +3217,8 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! constant viscocity for debugging elseif (trim(CS%ice_viscosity_compute) == "OBS") then if (CS%AGlen_visc(i,j) >0) then - CS%ice_visc(i,j,1) = max(CS%AGlen_visc(i,j) * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)),& - CS%min_ice_visc) + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(CS%AGlen_visc(i,j) ,CS%min_ice_visc) endif ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file elseif (model_qp1) then @@ -3091,8 +3247,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & v_shlf(I,J-1) * CS%PhiC(4,i,j)) - CS%ice_visc(i,j,1) = max(0.5 * Visc_coef * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & - (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)) * & + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) elseif (model_qp4) then !calculate viscosity at 4 quadrature points per cell @@ -3121,8 +3278,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) - CS%ice_visc(i,j,2*(jq-1)+iq) = max(0.5 * Visc_coef * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & - (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)) * & + CS%ice_visc(i,j,2*(jq-1)+iq) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) enddo; enddo endif @@ -3707,7 +3865,7 @@ end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, !! subject to a mask. subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf) - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & From 9d4f9d1c8cd630e29de06ab4dea76dd47df8a915 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Mon, 30 Sep 2024 13:43:18 -0400 Subject: [PATCH 106/128] Use loops instead of array syntax when calculating ice-shelf diagnostics. Also fixed incorrect loop bounds for a seldom-used ice-shelf convergence criterion --- src/ice_shelf/MOM_ice_shelf.F90 | 12 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 156 ++++++++++++++++------- 2 files changed, 121 insertions(+), 47 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6e248eb607..b904515fca 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -2648,7 +2648,9 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh endif if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt call masked_var_grounded(G,CS%dCS,dh_adott,tmp) - tmp(:,:) = dh_adott(:,:) - tmp(:,:) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) @@ -2710,7 +2712,9 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh endif if (CS%id_Ant_f_adott > 0 .or. CS%id_Ant_f_adot > 0) then !floating only: surface accumulation - surface melt call masked_var_grounded(G,CS%dCS,dh_adott,tmp) - tmp(:,:) = dh_adott(:,:) - tmp(:,:) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) if (CS%id_Ant_f_adott > 0) call post_scalar_data(CS%id_Ant_f_adott,val ,CS%diag) if (CS%id_Ant_f_adot > 0) call post_scalar_data(CS%id_Ant_f_adot ,val*Itime_step,CS%diag) @@ -2772,7 +2776,9 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh endif if (CS%id_Gr_f_adott > 0 .or. CS%id_Gr_f_adot > 0) then !floating only: surface accumulation - surface melt call masked_var_grounded(G,CS%dCS,dh_adott,tmp) - tmp(:,:) = dh_adott(:,:) - tmp(:,:) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo; enddo call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) if (CS%id_Gr_f_adott > 0) call post_scalar_data(CS%id_Gr_f_adott,val ,CS%diag) if (CS%id_Gr_f_adot > 0) call post_scalar_data(CS%id_Gr_f_adot ,val*Itime_step,CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index d9c372761d..5680e322be 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1081,48 +1081,63 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y, taud ! area-averaged driving stress [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged vertically integrated ice viscosity !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! area-averaged taub_beta field related to basal traction, !! [R L1 T-1 ~> Pa s m-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)) :: ice_speed ! ice sheet flow speed [L T-1 ~> m s-1] + + integer :: i,j call enable_averages(time_step, 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_shelf_speed > 0) call post_data(CS%id_shelf_speed, sqrt((CS%u_shelf**2) + (CS%v_shelf**2)), CS%diag) + if (CS%id_shelf_speed > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + ice_speed(I,J) = sqrt((CS%u_shelf(I,J)**2) + (CS%v_shelf(I,J)**2)) + enddo ; enddo + call post_data(CS%id_shelf_speed, ice_speed, CS%diag) + endif ! 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%IareaBu(:,:) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_x(I,J) = CS%taudx_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo 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%IareaBu(:,:) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_y(I,J) = CS%taudy_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif if (CS%id_taud_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) - call post_data(CS%id_taud_shelf, sqrt((taud_x**2)+(taud_y**2)), CS%diag) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud(I,J) = sqrt((CS%taudx_shelf(I,J)**2)+(CS%taudy_shelf(I,J)**2))*G%IareaBu(I,J) + enddo ; enddo + call post_data(CS%id_taud_shelf, taud, CS%diag) endif if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag) if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag) - if (CS%id_surf_slope_mag_shelf > 0) & - call post_data(CS%id_surf_slope_mag_shelf, sqrt((CS%sx_shelf**2)+(CS%sy_shelf**2)), CS%diag) + if (CS%id_surf_slope_mag_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + surf_slope(I,J) = sqrt((CS%sx_shelf(I,J)**2)+(CS%sy_shelf(I,J)**2)) + enddo ; enddo + call post_data(CS%id_surf_slope_mag_shelf, surf_slope, CS%diag) + endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) then - if (CS%visc_qps==4) then - ice_visc(:,:) = (0.25 * G%IareaT(:,:)) * & - ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3))) - else - ice_visc(:,:) = CS%ice_visc(:,:,1)*G%IareaT(:,:) - endif + call ice_visc_diag(CS,G,ice_visc) 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(:,:) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + basal_tr(i,j) = CS%basal_traction(i,j)*G%IareaT(i,j) + enddo ; enddo 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) @@ -1142,6 +1157,27 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) call disable_averaging(CS%diag) end subroutine IS_dynamics_post_data +!> Calculate cell-centered, area-averaged, vertically integrated ice viscosity for diagnostics +subroutine ice_visc_diag(CS,G,ice_visc) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), intent(out) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + integer :: i,j + + ice_visc(:,:)=0.0 + if (CS%visc_qps==4) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = (0.25 * G%IareaT(i,j)) * & + ((CS%ice_visc(i,j,1) + CS%ice_visc(i,j,4)) + (CS%ice_visc(i,j,2) + CS%ice_visc(i,j,3))) + enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = CS%ice_visc(i,j,1)*G%IareaT(i,j) + enddo ; enddo + endif +end subroutine ice_visc_diag + !> Writes the total ice shelf kinetic energy and mass to an ascii file subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure @@ -1504,7 +1540,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) err_init = 0 ; err_tempu = 0 ; err_tempv = 0 - do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu @@ -1586,7 +1622,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i err_max = 0 - do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -3071,10 +3107,13 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G) real, dimension(SZDIB_(G),SZDJB_(G)) :: Hv ! Ice shelf v_flux at corners [Z L T-1 ~> m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)) :: Hux ! Ice shelf d(u_flux)/dx at cell centers [Z T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)) :: Hvy ! Ice shelf d(v_flux)/dy at cell centers [Z T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! 2-D flux divergence div(uH) [Z T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! 2-D strain-rate components xx,yy, and xy [T-1 ~> s-1] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc_loc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s] - real, dimension(SZDI_(G),SZDJ_(G)) :: p1,p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! horizontal flux divergence div(uH) [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! strain-rate components xx,yy, and xy [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_strain_rate ! horizontal principal strain-rates [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),3) :: dev_stress ! deviatoric stress components xx,yy, and xy [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_dev_stress ! horizontal principal deviatoric stress [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s] + real :: p1,p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1] integer :: i, j !Allocate the gradient basis functions for 1 cell-centered quadrature point per cell @@ -3088,9 +3127,17 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G) !Calculate flux divergence and its components if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0) then call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) - Hu(:,:) = (H_node(:,:) * CS%u_shelf(:,:)) - Hv(:,:) = (H_node(:,:) * CS%v_shelf(:,:)) - Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 + + Hu(:,:) = 0.0; Hv(:,:) = 0.0; Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) > 0) then + Hu(I,J) = (H_node(I,J) * CS%u_shelf(I,J)) + endif + if (CS%vmask(I,J) > 0) then + Hv(I,J) = (H_node(I,J) * CS%v_shelf(I,J)) + endif + enddo; enddo + do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then !components of flux divergence at cell centers @@ -3099,12 +3146,13 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G) Hvy(i,j) = (((Hv(I-1,J-1) * CS%PhiC(2,i,j)) + (Hv(I,J ) * CS%PhiC(8,i,j))) + & ((Hv(I-1,J ) * CS%PhiC(6,i,j)) + (Hv(I,J-1) * CS%PhiC(4,i,j)))) + flux_div(i,j) = Hux(i,j) + Hvy(i,j) endif enddo ; enddo if (CS%id_duHdx > 0) call post_data(CS%id_duHdx, Hux, CS%diag) if (CS%id_dvHdy > 0) call post_data(CS%id_dvHdy, Hvy, CS%diag) - if (CS%id_fluxdiv > 0) call post_data(CS%id_fluxdiv, Hux+Hvy, CS%diag) + if (CS%id_fluxdiv > 0) call post_data(CS%id_fluxdiv, flux_div, CS%diag) endif if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & @@ -3135,30 +3183,50 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G) if (CS%id_strainrate_yy > 0) call post_data(CS%id_strainrate_yy, strain_rate(:,:,2), CS%diag) if (CS%id_strainrate_xy > 0) call post_data(CS%id_strainrate_xy, strain_rate(:,:,3), CS%diag) - if (CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0 .or. & CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then - p1(:,:) = 0.5*( strain_rate(:,:,1) + strain_rate(:,:,2)) - p2(:,:) = sqrt( (( 0.5 * (strain_rate(:,:,1) - strain_rate(:,:,2)) )**2) + (strain_rate(:,:,3)**2) ) - endif + p_strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + p1 = 0.5*( strain_rate(i,j,1) + strain_rate(i,j,2)) + p2 = sqrt( (( 0.5 * (strain_rate(i,j,1) - strain_rate(i,j,2)) )**2) + (strain_rate(i,j,3)**2) ) + p_strain_rate(i,j,1) = p1+p2 !Max horizontal principal strain-rate + p_strain_rate(i,j,2) = p1-p2 !Min horizontal principal strain-rate + enddo ; enddo - if (CS%id_pstrainrate_1 > 0) call post_data(CS%id_pstrainrate_1, p1+p2, CS%diag) - if (CS%id_pstrainrate_2 > 0) call post_data(CS%id_pstrainrate_2, p1-p2, CS%diag) + if (CS%id_pstrainrate_1 > 0) call post_data(CS%id_pstrainrate_1, p_strain_rate(:,:,1), CS%diag) + if (CS%id_pstrainrate_2 > 0) call post_data(CS%id_pstrainrate_2, p_strain_rate(:,:,2), CS%diag) + endif if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then - if (CS%visc_qps==4) then - ice_visc_loc(:,:) = ((0.25 * G%IareaT(:,:)) * & - ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3)))) / ISS%h_shelf(:,:) - else - ice_visc_loc(:,:) = (CS%ice_visc(:,:,1)*G%IareaT(:,:)) / ISS%h_shelf(:,:) + + call ice_visc_diag(CS,G,ice_visc) + + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0) then + dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + dev_stress(i,j,1) = 2*ice_visc(i,j)*strain_rate(i,j,1)/ISS%h_shelf(i,j) !deviatoric stress xx + dev_stress(i,j,2) = 2*ice_visc(i,j)*strain_rate(i,j,2)/ISS%h_shelf(i,j) !deviatoric stress yy + dev_stress(i,j,3) = 2*ice_visc(i,j)*strain_rate(i,j,3)/ISS%h_shelf(i,j) !deviatoric stress xy + endif + enddo; enddo + if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, dev_stress(:,:,1), CS%diag) + if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, dev_stress(:,:,2), CS%diag) + if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, dev_stress(:,:,3), CS%diag) endif - if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, 2*ice_visc_loc*strain_rate(:,:,1), CS%diag) - if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, 2*ice_visc_loc*strain_rate(:,:,2), CS%diag) - if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, 2*ice_visc_loc*strain_rate(:,:,3), CS%diag) - if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, 2*ice_visc_loc*(p1+p2), CS%diag) - if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, 2*ice_visc_loc*(p1-p2), CS%diag) + if (CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p_dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + p_dev_stress(i,j,1) = 2*ice_visc(i,j)*p_strain_rate(i,j,1)/ISS%h_shelf(i,j) !max horiz principal dev stress + p_dev_stress(i,j,2) = 2*ice_visc(i,j)*p_strain_rate(i,j,2)/ISS%h_shelf(i,j) !min horiz principal dev stress + endif + enddo; enddo + if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, p_dev_stress(:,:,1), CS%diag) + if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, p_dev_stress(:,:,2), CS%diag) + endif endif endif end subroutine IS_dynamics_post_data_2 From b240e7ee590adacdbc4eb4b1ff57974d69918a07 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Tue, 1 Oct 2024 12:11:51 -0400 Subject: [PATCH 107/128] change default for ice-shelf nonlin_solve_err_mode to 3 --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 5680e322be..7ccadb226e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -558,7 +558,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1), relative change since last iteration (2), or change in norm (3)", default=1) + "residual (1), relative change since last iteration (2), or change in norm (3)", default=3) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & From f90b071b1ab4a62d879fcf57597d89194071607e Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Mon, 7 Oct 2024 17:16:36 -0400 Subject: [PATCH 108/128] Ice-shelf FMAs (#729) * Fixes to preserve rotational symmetry when using Fused-multiply-adds Tested in ice-ocean mode and ice-shelf-only mode using ISOMIP and MISOMIP+, respectively * Added more parentheses to preserve rotational symmetry when using FMAs. Note that the changes here are to the MOM_ice_shelf_dynamics.F90 function 'quad_area', which is only called by the subroutine 'bilinear_shape_functions'; this subroutine is currently unused so that rotationally-consistent use of FMAs in both 'quad_area' and 'bilinear_shape_functions' has not been tested --- src/ice_shelf/MOM_ice_shelf.F90 | 8 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 234 +++++++++++------------ 2 files changed, 121 insertions(+), 121 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index b904515fca..bac5b0fce9 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -450,11 +450,11 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au - tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av + taux2 = (((asu1 * (sfc_state%taux_shelf(I-1,j)**2)) + (asu2 * (sfc_state%taux_shelf(I,j)**2)) ) * I_au) + tauy2 = (((asv1 * (sfc_state%tauy_shelf(i,J-1)**2)) + (asv2 * (sfc_state%tauy_shelf(i,J)**2)) ) * I_av) endif - u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au - v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av + u2_av = (((asu1 * (sfc_state%u(I-1,j)**2)) + (asu2 * sfc_state%u(I,j)**2)) * I_au) + v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asu2 * sfc_state%v(i,J)**2)) * I_av) if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then if (CS%ustar_max >= 0.0) then diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 7ccadb226e..9c7dda22de 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -288,9 +288,9 @@ function quad_area (X, Y) ! | | ! 1 - 2 - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + p2 = ( ((X(4)-X(1))**2) + ((Y(4)-Y(1))**2) ) ; q2 = ( ((X(3)-X(2))**2) + ((Y(3)-Y(2))**2) ) + a2 = ( ((X(3)-X(4))**2) + ((Y(3)-Y(4))**2) ) ; c2 = ( ((X(1)-X(2))**2) + ((Y(1)-Y(2))**2) ) + b2 = ( ((X(2)-X(4))**2) + ((Y(2)-Y(4))**2) ) ; d2 = ( ((X(3)-X(1))**2) + ((Y(3)-Y(1))**2) ) quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) end function quad_area @@ -937,10 +937,10 @@ function ice_time_step_CFL(CS, ISS, G) min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & - ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & - G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & - (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & - G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + (((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel)) + & + (G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel))) + & + ((G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel)) + & + (G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel)))) min_dt = min(min_dt, dt_local) endif ; enddo ; enddo ! i- and j- loops @@ -1247,8 +1247,8 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) do j=js,je ; do i=is,ie tmp1(i,j) = (KE_scale_factor * 0.03125) * (mass(i,j) * area(i,j)) * & - (((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2 + & - ((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2) + ((((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2) + & + (((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2)) enddo; enddo KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -1649,7 +1649,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%vmask(I,J) == 1) then err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) if (err_tempv >= err_max) err_max = err_tempv - tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + tempv = SQRT((v_shlf(I,J)**2) + (tempu**2)) endif if (tempv >= max_vel) max_vel = tempv enddo ; enddo @@ -2700,53 +2700,53 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, qp = 2*(jq-1)+iq !current quad point - uq = (u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - u_shlf(I,J) * (xquad(iq) * xquad(jq))) + & - (u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + uq = ((u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (u_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) - vq = (v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - v_shlf(I,J) * (xquad(iq) * xquad(jq))) + & - (v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + vq = ((v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (v_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) - ux = (u_shlf(I-1,J-1) * Phi(1,qp,i,j) + & - u_shlf(I,J) * Phi(7,qp,i,j)) + & - (u_shlf(I,J-1) * Phi(3,qp,i,j) + & - u_shlf(I-1,J) * Phi(5,qp,i,j)) + ux = ((u_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (u_shlf(I,J) * Phi(7,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(5,qp,i,j))) - vx = (v_shlf(I-1,J-1) * Phi(1,qp,i,j) + & - v_shlf(I,J) * Phi(7,qp,i,j)) + & - (v_shlf(I,J-1) * Phi(3,qp,i,j) + & - v_shlf(I-1,J) * Phi(5,qp,i,j)) + vx = ((v_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (v_shlf(I,J) * Phi(7,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(5,qp,i,j))) - uy = (u_shlf(I-1,J-1) * Phi(2,qp,i,j) + & - u_shlf(I,J) * Phi(8,qp,i,j)) + & - (u_shlf(I,J-1) * Phi(4,qp,i,j) + & - u_shlf(I-1,J) * Phi(6,qp,i,j)) + uy = ((u_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (u_shlf(I,J) * Phi(8,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(6,qp,i,j))) - vy = (v_shlf(I-1,J-1) * Phi(2,qp,i,j) + & - v_shlf(I,J) * Phi(8,qp,i,j)) + & - (v_shlf(I,J-1) * Phi(4,qp,i,j) + & - v_shlf(I-1,J) * Phi(6,qp,i,j)) + vy = ((v_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (v_shlf(I,J) * Phi(8,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(6,qp,i,j))) if (visc_qp4) qpv = qp !current quad point for viscosity do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & - ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & - (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + ((basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq))) if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & - (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + ((basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq))) endif enddo ; enddo enddo ; enddo @@ -2824,13 +2824,13 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0 do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 - hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) + hloc = ((Phisub(qx,qy,i,j,1,1)*H(1,1)) + (Phisub(qx,qy,i,j,2,2)*H(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H(1,2)) + (Phisub(qx,qy,i,j,2,1)*H(2,1))) if (dens_ratio * hloc - bathyT > 0) then - uloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) - vloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) + uloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * U(1,1)) + (Phisub(qx,qy,i,j,2,2) * U(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * U(1,2)) + (Phisub(qx,qy,i,j,2,1) * U(2,1)))) + vloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * V(1,1)) + (Phisub(qx,qy,i,j,2,2) * V(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * V(1,2)) + (Phisub(qx,qy,i,j,2,1) * V(2,1)))) endif enddo; enddo ; enddo ; enddo @@ -2981,8 +2981,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, vy = 0. u_diag_qp(iphi,jphi,qp) = & - ice_visc(i,j,qpv) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + ice_visc(i,j,qpv) * (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) @@ -2999,8 +2999,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, uy = 0. v_diag_qp(iphi,jphi,qp) = & - ice_visc(i,j,qpv) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + ice_visc(i,j,qpv) * (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) @@ -3031,15 +3031,15 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) - if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) - if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) - if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) - if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) - if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) - if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) - if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) - if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) endif endif ; enddo ; enddo @@ -3076,8 +3076,8 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd grnd_stat(:,:,:,:)=0 do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 - hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) + hloc = ((Phisub(qx,qy,i,j,1,1)*H_node(1,1)) + (Phisub(qx,qy,i,j,2,2)*H_node(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H_node(1,2)) + (Phisub(qx,qy,i,j,2,1)*H_node(2,1))) if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 enddo; enddo ; enddo ; enddo @@ -3295,25 +3295,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) ! Units of Aglen_visc [Pa-(n_g) s-1] - ux = (u_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & - u_shlf(I,J) * CS%PhiC(7,i,j)) + & - (u_shlf(I-1,J) * CS%PhiC(5,i,j) + & - u_shlf(I,J-1) * CS%PhiC(3,i,j)) + ux = ((u_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (u_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(3,i,j))) - vx = (v_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & - v_shlf(I,J) * CS%PhiC(7,i,j)) + & - (v_shlf(I-1,J) * CS%PhiC(5,i,j) + & - v_shlf(I,J-1) * CS%PhiC(3,i,j)) + vx = ((v_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (v_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(3,i,j))) - uy = (u_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & - u_shlf(I,J) * CS%PhiC(8,i,j)) + & - (u_shlf(I-1,J) * CS%PhiC(6,i,j) + & - u_shlf(I,J-1) * CS%PhiC(4,i,j)) + uy = ((u_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (u_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(4,i,j))) - vy = (v_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & - v_shlf(I,J) * CS%PhiC(8,i,j)) + & - (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & - v_shlf(I,J-1) * CS%PhiC(4,i,j)) + vy = ((v_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (v_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(4,i,j))) CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & max(0.5 * Visc_coef * & @@ -3326,25 +3326,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) do iq=1,2 ; do jq=1,2 - ux = (u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & - (u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + ux = ((u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) - vx = (v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & - (v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + vx = ((v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) - uy = (u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & - (u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + uy = ((u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) - vy = (v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & - (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + vy = ((v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) CS%ice_visc(i,j,2*(jq-1)+iq) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & max(0.5 * Visc_coef * & @@ -3407,7 +3407,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = US%L_T_to_m_s * sqrt( (umid**2 + vmid**2) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) + unorm = US%L_T_to_m_s * sqrt( ((umid**2) + (vmid**2)) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) !Coulomb friction (Schoof 2005, Gagliardini et al 2007) if (CS%CoulombFriction) then @@ -3584,10 +3584,10 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) do qpoint=1,4 - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) + a = ((-X(1)*(1-yquad(qpoint)))+(X(4)*yquad(qpoint))) + ((X(2)*(1-yquad(qpoint)))-(X(3)*yquad(qpoint))) !d(x)/d(x*) + b = ((-Y(1)*(1-yquad(qpoint)))+(Y(4)*yquad(qpoint))) + ((Y(2)*(1-yquad(qpoint)))-(Y(3)*yquad(qpoint))) !d(y)/d(x*) + c = ((-X(1)*(1-xquad(qpoint)))+(X(4)*xquad(qpoint))) + ((-X(2)*xquad(qpoint))+(X(3)*(1-xquad(qpoint))))!d(x)/d(y*) + d = ((-Y(1)*(1-xquad(qpoint)))+(Y(4)*xquad(qpoint))) + ((-Y(2)*xquad(qpoint))+(Y(3)*(1-xquad(qpoint))))!d(y)/d(y*) do node=1,4 @@ -3605,8 +3605,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) xexp = xquad(qpoint) endif - Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) + Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) enddo enddo @@ -3646,12 +3646,12 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) do qpoint=1,4 if (J>1) then - a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) + 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 - d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + d = (G%dyCu(I-1,j) * (1-xquad(qpoint))) + (G%dyCu(I,j) * xquad(qpoint)) ! d(y)/d(y*) else d = G%dyCu(I,j) !* xquad(qpoint) endif @@ -4168,8 +4168,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) @@ -4182,8 +4182,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) @@ -4213,8 +4213,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) @@ -4229,8 +4229,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not @@ -4334,8 +4334,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) @@ -4347,8 +4347,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) endif @@ -4374,8 +4374,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not @@ -4386,8 +4386,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not From 80d8b5ff0d21dca62477c7004cf7724805ff7d28 Mon Sep 17 00:00:00 2001 From: He Wang Date: Wed, 18 Sep 2024 14:32:54 -0400 Subject: [PATCH 109/128] Bugfix in MOM_porous_barriers Fix a bug that layer/interface weights may not be reset to 1.0 if no calculations are needed. The bug has negligible impact for barotropic applications but may affect baroclinic runs which are yet to performed. --- src/core/MOM.F90 | 8 +-- src/core/MOM_porous_barriers.F90 | 64 ++++++++++++------- src/core/MOM_variables.F90 | 1 - .../MOM_fixed_initialization.F90 | 1 + 4 files changed, 45 insertions(+), 29 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e6cd3cf747..b696213e1b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2799,10 +2799,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0 !allocate porous topography variables - allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz)) ; CS%pbv%por_face_areaU(:,:,:) = 1.0 - allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz)) ; CS%pbv%por_face_areaV(:,:,:) = 1.0 - allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1)) ; CS%pbv%por_layer_widthU(:,:,:) = 1.0 - allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1)) ; CS%pbv%por_layer_widthV(:,:,:) = 1.0 + allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz), source=1.0) + allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz), source=1.0) + allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1), source=1.0) + allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1), source=1.0) ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index 8f872ceb15..e24d4954cb 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -122,16 +122,20 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) A_layer_prev(I,j) = A_layer endif ; enddo ; enddo ; enddo else - do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then - call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & - eta_u(I,j,K), A_layer, do_I(I,j)) - if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then - pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then + pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) + else + pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(I,j) = A_layer else - pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice + pbv%por_face_areaU(I,j,k) = 1.0 endif - A_layer_prev(I,j) = A_layer - endif ; enddo ; enddo ; enddo + enddo ; enddo ; enddo endif ! v-points @@ -154,16 +158,20 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) A_layer_prev(i,J) = A_layer endif ; enddo ; enddo ; enddo else - do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then - call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & - eta_v(i,J,K), A_layer, do_I(i,J)) - if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then - pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then + pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) + else + pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(i,J) = A_layer else - pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice + pbv%por_face_areaV(i,J,k) = 1.0 endif - A_layer_prev(i,J) = A_layer - endif ; enddo ; enddo ; enddo + enddo ; enddo ; enddo endif if (CS%debug) then @@ -231,10 +239,14 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) endif ; enddo ; enddo ; enddo else - do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then - call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & - eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) - endif ; enddo ; enddo ; enddo + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + else + pbv%por_layer_widthU(I,j,K) = 1.0 + endif + enddo ; enddo ; enddo endif ! v-points @@ -249,10 +261,14 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) endif ; enddo ; enddo ; enddo else - do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then - call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & - eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) - endif ; enddo ; enddo ; enddo + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + else + pbv%por_layer_widthV(i,J,K) = 1.0 + endif + enddo ; enddo ; enddo endif if (CS%debug) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 5b7740230a..65e915705a 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -323,7 +323,6 @@ module MOM_variables end type BT_cont_type !> Container for grids modifying cell metric at porous barriers -! TODO: rename porous_barrier_type to porous_barrier_type type, public :: porous_barrier_type ! Each of the following fields has nz layers. real, allocatable :: por_face_areaU(:,:,:) !< fractional open area of U-faces [nondim] diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index ea45e0cc2f..f54eb8a638 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -146,6 +146,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) endif ! Read sub-grid scale topography parameters at velocity points used for porous barrier calculation + ! TODO: The following routine call may eventually be merged as one of the CHANNEL_CONFIG options call get_param(PF, mdl, "SUBGRID_TOPO_AT_VEL", read_porous_file, & "If true, use variables from TOPO_AT_VEL_FILE as parameters for porous barrier.", & default=.False.) From 79979a9d6306641119026834a22b27aedb059a56 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 10 Apr 2024 13:29:19 -0400 Subject: [PATCH 110/128] Update version of checkout action (@v4) Other than staying up to date, this purportedly fixes a "Node.js deprecation" message we first noticed in the coverage workflow but has appeared elsewhere intermittently. --- .github/workflows/coupled-api.yml | 2 +- .github/workflows/coverage.yml | 2 +- .github/workflows/documentation-and-style.yml | 2 +- .github/workflows/expression.yml | 2 +- .github/workflows/macos-regression.yml | 2 +- .github/workflows/macos-stencil.yml | 2 +- .github/workflows/other.yml | 2 +- .github/workflows/perfmon.yml | 2 +- .github/workflows/regression.yml | 2 +- .github/workflows/stencil.yml | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 2d99b45967..ace02ee790 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 1f5a64ac56..8b3dc944bd 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml index 3ca7f0e613..857db917b6 100644 --- a/.github/workflows/documentation-and-style.yml +++ b/.github/workflows/documentation-and-style.yml @@ -8,7 +8,7 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/expression.yml b/.github/workflows/expression.yml index 5860d32e37..3cd19ee18c 100644 --- a/.github/workflows/expression.yml +++ b/.github/workflows/expression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index d769e15131..16e2e15f80 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -17,7 +17,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index 6e77a5c4a6..a30ad17199 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -17,7 +17,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml index 2cba17ae76..9a941bafa9 100644 --- a/.github/workflows/other.yml +++ b/.github/workflows/other.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 8fd314cee3..a66ba90643 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml index 7cdd0a5cd6..107948d5da 100644 --- a/.github/workflows/regression.yml +++ b/.github/workflows/regression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive diff --git a/.github/workflows/stencil.yml b/.github/workflows/stencil.yml index c85945072c..d46da6e4fa 100644 --- a/.github/workflows/stencil.yml +++ b/.github/workflows/stencil.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: submodules: recursive From 795e982c42751eb0e7205ba503424bf8a503c67f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 29 Oct 2024 11:37:13 -0400 Subject: [PATCH 111/128] Switch runner and allow for more run time - Changed gitlab runner to the mom6-account on gaea - Added gitlab variable MOM6_RUN_JOB_DURATION to control the allowed run duration during bad days for the system. Defaults to 15:00 (15 mins) - Added FC=ftn MPIFC=ftn CC=cc environment vars when invoking make in .testing --- .gitlab-ci.yml | 92 +++++++++++++++++++++++++------------------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 55494696ae..39512c0dd1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: # that is unique to this pipeline. # We use the "fetch" strategy to speed up the startup of stages variables: - JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" + JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.mom6-account/runner/builds/$CI_PIPELINE_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR @@ -20,7 +20,7 @@ before_script: p:merge: stage: setup tags: - - ncrc5 + - mom6-ci-c5 script: - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl @@ -30,7 +30,7 @@ p:merge: p:clone: stage: setup tags: - - ncrc5 + - mom6-ci-c5 script: # NOTE: We could sweep any builds older than 3 days here if needed #- find $HOME/ci/[0-9]* -mtime +3 -delete 2> /dev/null || true @@ -45,7 +45,7 @@ p:clone: s:work-space:pgi: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space pgi @@ -53,7 +53,7 @@ s:work-space:pgi: s:work-space:intel: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space intel @@ -61,7 +61,7 @@ s:work-space:intel: s:work-space:gnu: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu @@ -69,7 +69,7 @@ s:work-space:gnu: s:work-space:gnu-restarts: stage: setup tags: - - ncrc5 + - mom6-ci-c5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst @@ -83,7 +83,7 @@ compile:pgi:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi @@ -91,7 +91,7 @@ compile:intel:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel @@ -99,7 +99,7 @@ compile:gnu:repro: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu @@ -107,7 +107,7 @@ compile:gnu:debug: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu @@ -115,7 +115,7 @@ compile:gnu:ocean-only-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu @@ -123,7 +123,7 @@ compile:gnu:ice-ocean-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu @@ -133,36 +133,36 @@ run:pgi: stage: run needs: ["s:work-space:pgi","compile:pgi:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-pgi-SNL || ( echo Batch job did not complete ; exit 911 ) run:intel: stage: run needs: ["s:work-space:intel","compile:intel:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-intel-SNL || ( echo Batch job did not complete ; exit 911 ) run:gnu: stage: run needs: ["s:work-space:gnu","compile:gnu:repro","compile:gnu:debug"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-SNLDT || ( echo Batch job did not complete ; exit 911 ) run:gnu-restarts: stage: run needs: ["s:work-space:gnu-restarts","compile:gnu:repro"] tags: - - ncrc5 + - mom6-ci-c5 script: - - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=${MOM6_RUN_JOB_DURATION:=15:00} --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-R || ( echo Batch job did not complete ; exit 911 ) # GH/autoconf tests (duplicates the GH actions tests) @@ -174,7 +174,7 @@ actions:gnu: stage: tests needs: [] tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -182,9 +182,9 @@ actions:gnu: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-gnu PrgEnv-intel PrgEnv-nvhpc ; module load PrgEnv-gnu ; module unload gcc ; module load gcc/12.2.0 cray-hdf5 cray-netcdf - - make -s -j - - MPIRUN= make preproc -s -j + - module unload darshan-runtime intel PrgEnv-intel ; module load PrgEnv-gnu/8.5.0 cray-hdf5 cray-netcdf ; module switch gcc-native/12.3 + - FC=ftn MPIFC=ftn CC=cc make -s -j + - MPIRUN= FC=ftn MPIFC=ftn CC=cc make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s @@ -194,7 +194,7 @@ actions:intel: stage: tests needs: [] tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -202,9 +202,9 @@ actions:intel: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu ; module load PrgEnv-intel; module unload intel; module load intel-classic/2022.0.2 cray-hdf5 cray-netcdf - - make -s -j - - MPIRUN= make preproc -s -j + - module unload darshan-runtime ; module unload intel cray-libsci cray-mpich PrgEnv-intel ; module load PrgEnv-intel intel/2023.2.0 cray-hdf5 cray-netcdf cray-mpich + - FC=ftn MPIFC=ftn CC=cc make -s -j + - MPIRUN= FC=ftn MPIFC=ftn CC=cc make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s @@ -219,7 +219,7 @@ t:pgi:symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi S @@ -227,7 +227,7 @@ t:pgi:non-symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi N @@ -235,7 +235,7 @@ t:pgi:layout: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi L @@ -243,7 +243,7 @@ t:pgi:params: stage: tests needs: ["run:pgi"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params pgi allow_failure: true @@ -252,7 +252,7 @@ t:intel:symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel S @@ -260,7 +260,7 @@ t:intel:non-symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel N @@ -268,7 +268,7 @@ t:intel:layout: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel L @@ -276,7 +276,7 @@ t:intel:params: stage: tests needs: ["run:intel"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params intel allow_failure: true @@ -285,7 +285,7 @@ t:gnu:symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu S @@ -293,7 +293,7 @@ t:gnu:non-symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu N @@ -301,7 +301,7 @@ t:gnu:layout: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu L @@ -309,7 +309,7 @@ t:gnu:static: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu T @@ -317,7 +317,7 @@ t:gnu:symmetric-debug: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu D @@ -325,7 +325,7 @@ t:gnu:restart: stage: tests needs: ["run:gnu-restarts"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu R @@ -333,7 +333,7 @@ t:gnu:params: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-params gnu allow_failure: true @@ -342,7 +342,7 @@ t:gnu:diags: stage: tests needs: ["run:gnu"] tags: - - ncrc5 + - mom6-ci-c5 script: - .gitlab/pipeline-ci-tool.sh check-diags gnu allow_failure: true @@ -351,7 +351,7 @@ t:gnu:diags: cleanup: stage: cleanup tags: - - ncrc5 + - mom6-ci-c5 before_script: - echo Skipping usual preamble script: From e189e05dfadf766a8980b2d1185825d4de850b2e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 27 Feb 2024 04:35:02 -0500 Subject: [PATCH 112/128] +Eliminated h_neglect argument to remapping_core_h Eliminated the previously optional h_neglect and h_neglect_edge arguments to remapping_core_h and remapping_core_w, and added optional h_neglect and h_neglect_edge arguments to initialize_remapping for storage in the remapping control structures. The answer_date, h_neglect and h_neglect_edge arguments to ALE_remap_scalar were also eliminated, as they are no longer used. The new routine open_boundary_setup_vert was added to manage these changes. A new verticalGrid_type argument was added to wave_speed_init. The h_neglect argument to 29 routines was made non-optional, because there is no way to provide a consistent hard-coded default for a dimensional parameter. The (mostly low-level) routines where this change to a non-optional h_neglect was made include build_reconstructions_1d, P1M_interpolation, P3M_interpolation, P3M_boundary_extrapolation, PLM_reconstruction, PLM_boundary_extrapolation, PPM_reconstruction, PPM_limiter_standard, PPM_boundary_extrapolation, PQM_reconstruction, PQM_limiter, PQM_boundary_extrapolation_v1, build_hycom1_column, build_rho_column, bound_edge_values, edge_values_explicit_h4, edge_values_explicit_h4cw, edge_values_implicit_h4, edge_slopes_implicit_h3, edge_slopes_implicit_h5, edge_values_implicit_h6, regridding_set_ppolys, build_and_interpolate_grid, remapByProjection, remapByDeltaZ, and integrateReconOnInterval. In two modules (MOM_open_boundary and MOM_wave_speed), two separate copies of remapping_CS variables were needed to accommodate different negligible thicknesses or units in different remapping calls. In those cases that also have an optional h_neglect_edge argument the default is now set to h_neglect. Improperly hard-coded dimensional default values for h_neglect or h_neglect_edge were eliminated in 16 places as a result of this change, but they were added back in 2 unit testing routines (one of these is archaic and unused) that do not use exercise dimensional rescaling tests. Because the previously optional arguments were already present in all calls from the dev/gfdl or main branches of the MOM6 code, and because the places where arguments have been removed they are balanced by equivalent arguments added to initialize_remapping, all answers are bitwise identical in the regression tests, but this change in interfaces could impact other code that is not in the main branch of MOM6. --- .../timing_tests/time_MOM_remapping.F90 | 7 +- src/ALE/MOM_ALE.F90 | 105 +++-------- src/ALE/MOM_remapping.F90 | 114 ++++++------ src/ALE/P1M_functions.F90 | 2 +- src/ALE/P3M_functions.F90 | 42 ++--- src/ALE/PLM_functions.F90 | 18 +- src/ALE/PPM_functions.F90 | 20 +- src/ALE/PQM_functions.F90 | 56 +++--- src/ALE/coord_hycom.F90 | 8 +- src/ALE/coord_rho.F90 | 8 +- src/ALE/regrid_edge_values.F90 | 112 ++++------- src/ALE/regrid_interp.F90 | 28 +-- src/ALE/remapping_attic.F90 | 38 ++-- src/core/MOM.F90 | 4 + src/core/MOM_open_boundary.F90 | 174 ++++++++++-------- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/diagnostics/MOM_wave_speed.F90 | 41 +++-- src/framework/MOM_diag_remap.F90 | 24 +-- .../MOM_state_initialization.F90 | 61 +++--- .../MOM_tracer_initialization_from_Z.F90 | 27 +-- src/ocean_data_assim/MOM_oda_driver.F90 | 35 ++-- src/ocean_data_assim/MOM_oda_incupd.F90 | 47 ++--- .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 37 ++-- .../vertical/MOM_tidal_mixing.F90 | 15 +- src/tracer/MOM_hor_bnd_diffusion.F90 | 21 +-- 27 files changed, 474 insertions(+), 576 deletions(-) diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 index 5f4c0258ca..e4bea9d94f 100644 --- a/config_src/drivers/timing_tests/time_MOM_remapping.F90 +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -17,8 +17,9 @@ program time_MOM_remapping real, dimension(nschemes) :: tmin ! Shortest time for a call [s] real, dimension(nschemes) :: tmax ! Longest time for a call [s] real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] -real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] [nondim] real :: start, finish ! Times [s] +real :: h_neglect ! A negligible thickness [nondim] real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] integer :: ij, k, isamp, iter, ischeme ! Indices and counters integer :: seed_size ! Number of integers used by seed @@ -50,6 +51,7 @@ program time_MOM_remapping h0(:,ij) = h0(:,ij) / h0sum h1(:,ij) = h1(:,ij) / h1sum enddo +h_neglect = 1.0-30 ! Loop over many samples of timing loop to collect statistics tmean(:) = 0. @@ -59,7 +61,8 @@ program time_MOM_remapping do isamp = 1, nsamp ! Time reconstruction + remapping do ischeme = 1, nschemes - call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme))) + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), & + h_neglect=h_neglect, h_neglect_edge=h_neglect) call cpu_time(start) do iter = 1, nits ! Make many passes to reduce sampling error do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 0ae5fb1e92..bc3099d68d 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -181,6 +181,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: om4_remap_via_sub_cells type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding ! for sharing parameters. + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -248,20 +249,30 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%answer_date) + answer_date=CS%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) call initialize_remapping( CS%vel_remapCS, vel_string, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%answer_date) + answer_date=CS%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) 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 "//& @@ -345,7 +356,7 @@ subroutine ALE_set_OM4_remap_algorithm( CS, om4_remap_via_sub_cells ) type(ALE_CS), pointer :: CS !< Module control structure logical, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm - call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells =om4_remap_via_sub_cells ) + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells=om4_remap_via_sub_cells ) end subroutine ALE_set_OM4_remap_algorithm @@ -591,8 +602,8 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, endif enddo ; enddo - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answer_date=CS%answer_date) - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answer_date=CS%answer_date) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S) if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, GV, h_new, Reg%Tr, Reg%ntr) @@ -653,7 +664,6 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface ! Interface height changes within ! an iteration [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzIntTotal ! Cumulative interface position changes [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] nz = GV%ke @@ -680,14 +690,6 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d if (present(dt)) & call ALE_update_regrid_weights(dt, CS) - if (CS%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 - else - h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 - endif - do itt = 1, n_itt call do_group_pass(pass_T_S_h, G%domain) @@ -704,10 +706,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! 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,:), & - 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,:), & - h_neglect, h_neglect_edge) + 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,:)) enddo ; enddo ! starting grid for next iteration @@ -763,7 +763,6 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) real :: Idt ! The inverse of the timestep [T-1 ~> 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() integer :: i, j, k, m, nz, ntr @@ -771,14 +770,6 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) show_call_tree = .false. if (present(debug)) show_call_tree = debug - if (CS%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - if (show_call_tree) call callTree_enter("ALE_remap_tracers(), MOM_ALE.F90") nz = GV%ke @@ -803,11 +794,9 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) h2(:) = h_new(i,j,:) 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) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, 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) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0. Note that this is not conservative! @@ -1091,7 +1080,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u 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 integer :: i, j, k, nz @@ -1099,14 +1087,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_remap_velocities()") - if (CS%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - nz = GV%ke ! --- Remap u profiles from the source vertical grid onto the new target grid. @@ -1120,8 +1100,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u u_src(k) = u(I,j,k) enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt) if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) @@ -1146,8 +1125,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u v_src(k) = v(i,J,k) enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & - h_neglect, h_neglect_edge) + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt) 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) @@ -1300,8 +1278,7 @@ 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. -subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap, & - answers_2018, answer_date, h_neglect, h_neglect_edge) +subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap) type(remapping_CS), intent(in) :: CS !< Remapping control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -1319,44 +1296,16 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c !! layers otherwise (default). logical, optional, intent(in) :: old_remap !< If true, use the old "remapping_core_w" !! method, otherwise use "remapping_core_h". - logical, optional, intent(in) :: answers_2018 !< If true, use the order of arithmetic - !! and expressions that recover the answers for - !! remapping from the end of 2018. Otherwise, - !! use more robust forms of the same expressions. - integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use - !! for remapping - real, optional, intent(in) :: h_neglect !< A negligibly small thickness used in - !! remapping cell reconstructions, in the same - !! units as h_src, often [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small thickness used in - !! remapping edge value calculations, in the same - !! units as h_src, often [H ~> m or kg m-2] - ! Local variables + ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) ! Change in interface position [H ~> m or kg m-2] - real :: h_neg, h_neg_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] - logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap + logical :: ignore_vanished_layers, use_remapping_core_w ignore_vanished_layers = .false. if (present(all_cells)) ignore_vanished_layers = .not. all_cells use_remapping_core_w = .false. if (present(old_remap)) use_remapping_core_w = old_remap n_points = nk_src - use_2018_remap = .true. ; if (present(answers_2018)) use_2018_remap = answers_2018 - if (present(answer_date)) use_2018_remap = (answer_date < 20190101) - - if (present(h_neglect)) then - h_neg = h_neglect - h_neg_edge = h_neg ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge - else - if (.not.use_2018_remap) then - h_neg = GV%H_subroundoff ; h_neg_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neg = GV%m_to_H*1.0e-30 ; h_neg_edge = GV%m_to_H*1.0e-10 - else - h_neg = GV%kg_m2_to_H*1.0e-30 ; h_neg_edge = GV%kg_m2_to_H*1.0e-10 - endif - endif !$OMP parallel do default(shared) firstprivate(n_points,dx) do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -1371,10 +1320,10 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c if (use_remapping_core_w) then call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, dx, s_dst(i,j,:), h_neg, h_neg_edge) + GV%ke, dx, s_dst(i,j,:)) else call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neg, h_neg_edge) + GV%ke, h_dst(i,j,:), s_dst(i,j,:)) endif else s_dst(i,j,:) = 0. diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 4495e4a170..3c2c0af6df 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -40,6 +40,13 @@ module MOM_remapping !> If true, use the OM4 version of the remapping algorithm that makes poor assumptions !! about the reconstructions in top and bottom layers of the source grid logical :: om4_remap_via_sub_cells = .false. + + !> A negligibly small width for the purpose of cell reconstructions in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect + !> A negligibly small width for the purpose of edge value calculations in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect_edge end type !> Class to assist in unit tests @@ -114,7 +121,8 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date) + om4_remap_via_sub_cells, answers_2018, answer_date, & + h_neglect, h_neglect_edge) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells @@ -124,6 +132,12 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of cell + !! reconstructions in the same units as the h0 argument + !! to remapping_core_h [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge + !! value calculations in the same units as as the h0 + !! argument to remapping_core_h [H] if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) @@ -153,6 +167,12 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(answer_date)) then CS%answer_date = answer_date endif + if (present(h_neglect)) then + CS%h_neglect = h_neglect + endif + if (present(h_neglect_edge)) then + CS%h_neglect_edge = h_neglect_edge + endif end subroutine remapping_set_param @@ -181,7 +201,7 @@ end subroutine extract_member_remapping_CS !! !! \todo Remove h_neglect argument by moving into remapping_CS !! \todo Remove PCM_cell argument by adding new method in Recon1D class -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, net_err, PCM_cell) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, 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 [H] @@ -189,12 +209,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0 [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H] real, optional, intent(out) :: net_err !< Error in total column [A H] logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. @@ -217,14 +231,10 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] - real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: iMethod ! An integer indicating the integration method used - 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, PCM_cell ) + CS%h_neglect, CS%h_neglect_edge, PCM_cell ) if (CS%om4_remap_via_sub_cells) then @@ -284,7 +294,7 @@ end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. -subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) +subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] @@ -292,12 +302,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid [H] real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0 [H]. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H]. + ! Local variables real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] @@ -317,15 +322,11 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] real, dimension(n1) :: h1 !< Cell widths on target grid [H] real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] - real :: hNeglect, hNeglect_edge ! Negligibly small thicknesses [H] integer :: iMethod ! An integer indicating the integration method used integer :: k - 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 ) + CS%h_neglect, CS%h_neglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) @@ -377,19 +378,23 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] integer, intent(out) :: iMethod !< Integration method - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0 [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0 [H] + 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]. + !! The default is h_neglect. logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for !! cells from the source grid where this is true. ! Local variables + real :: h_neg_edge ! A negligibly small width for the purpose of edge value + ! calculations in the same units as h0 [H] integer :: local_remapping_scheme integer :: k, n + h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge + ! Reset polynomial ppoly_r_E(:,:) = 0.0 ppoly_r_S(:,:) = 0.0 @@ -426,7 +431,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_CW ) ! identical to REMAPPING_PPM_HYBGEN - call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neg_edge ) call PPM_monotonicity( n0, u0, ppoly_r_E ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then @@ -434,14 +439,14 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) @@ -460,7 +465,7 @@ 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 ) iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & answer_date=CS%answer_date ) @@ -470,7 +475,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & answer_date=CS%answer_date ) @@ -1483,7 +1488,8 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date) + om4_remap_via_sub_cells, answers_2018, answer_date, & + h_neglect, h_neglect_edge) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1494,12 +1500,17 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of cell + !! reconstructions in the same units as h0 [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge + !! value calculations in the same units as h0 [H]. ! Note that remapping_scheme is mandatory for initialize_remapping() call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) end subroutine initialize_remapping @@ -1580,21 +1591,17 @@ logical function remapping_unit_tests(verbose) real :: u02_err ! Error in remaping [A] integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices integer :: answer_date ! The vintage of the expressions to test - real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be - ! added to thicknesses in a denominator without - ! changing the numerical result, except where - ! a division by zero would otherwise occur. real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] type(testing) :: test ! Unit testing convenience functions - integer :: om4 + integer :: i, om4 character(len=4) :: om4_tag call test%set( verbose=verbose ) ! Sets the verbosity flag in test answer_date = 20190101 ! 20181231 - h_neglect = hNeglect_dflt - h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + h_neglect = 1.0e-30 + h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' @@ -1603,7 +1610,8 @@ logical function remapping_unit_tests(verbose) if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' - call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) + call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Profile 0: 4 layers of thickness 0.75 and total depth 3, with du/dz=8 n0 = 4 @@ -1623,7 +1631,7 @@ logical function remapping_unit_tests(verbose) ! Mapping u1 from h1 to h2 call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1 ) call test%real_arr(3, u1, (/8.,0.,-8./), 'remapping_core_w() PPM_H4') allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) @@ -2067,7 +2075,7 @@ logical function remapping_unit_tests(verbose) u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) allocate( u1(8) ) - call initialize_remapping(CS, 'PLM', answer_date=99990101) + call initialize_remapping(CS, 'PLM', answer_date=99990101, h_neglect=1.e-17, h_neglect_edge=1.e-2) do om4 = 0, 1 if ( om4 == 0 ) then @@ -2079,27 +2087,27 @@ logical function remapping_unit_tests(verbose) endif ! Unchanged grid - call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1) call test%real_arr(8, u1, (/1.0,1.5,2.5,3.5,4.5,5.5,6.0,6.0/), 'PLM: remapped h=01111100->h=01111100'//om4_tag) ! Removing vanished layers (unchanged values for non-vanished layers, layer centers 0.5, 1.5, 2.5, 3.5, 4.5) - call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1) call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=11111'//om4_tag) ! Remapping to variable thickness layers (layer centers 0.25, 1.0, 2.25, 4.0) - call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1) call test%real_arr(4, u1, (/1.25,2.,3.25,5./), 'PLM: remapped h=01111100->h=h1t2'//om4_tag) ! Remapping to variable thickness + vanished layers (layer centers 0.25, 1.0, 1.5, 2.25, 4.0) - call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1) call test%real_arr(6, u1, (/1.25,2.,2.5,3.25,5.,6./), 'PLM: remapped h=01111100->h=h10t20'//om4_tag) ! Remapping to deeper water column (layer centers 0.75, 2.25, 3., 5., 8.) - call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1) call test%real_arr(5, u1, (/1.75,3.25,4.,5.5,6./), 'PLM: remapped h=01111100->h=tt02'//om4_tag) ! Remapping to slightly shorter water column (layer centers 0.5, 1.5, 2.5,, 3.5, 4.25) - call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1) if ( om4 == 0 ) then call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.25/), 'PLM: remapped h=01111100->h=1111h') else @@ -2107,7 +2115,7 @@ logical function remapping_unit_tests(verbose) endif ! Remapping to much shorter water column (layer centers 0.25, 0.5, 1.) - call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1, 1.e-17, 1.e-2) + call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1) if ( om4 == 0 ) then call test%real_arr(3, u1, (/1.25,1.5,2./), 'PLM: remapped h=01111100->h=h01') else diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 7889966135..d2051cc702 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -31,7 +31,7 @@ subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answe real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 6039b197fb..e9c234db32 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -10,9 +10,6 @@ module P3M_functions public P3M_interpolation public P3M_boundary_extrapolation -real, parameter :: hNeglect_dflt = 1.E-30 !< Default value of a negligible cell thickness -real, parameter :: hNeglect_edge_dflt = 1.E-10 !< Default value of a negligible edge thickness - contains !> Set up a piecewise cubic interpolation from cell averages and estimated @@ -32,7 +29,7 @@ subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_negle real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -66,7 +63,7 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -79,15 +76,9 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an real :: h_l, h_c, h_r ! left, center and right cell widths [H] real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] real :: slope ! retained PLM slope [A H-1] - real :: eps - real :: hNeglect ! A negligibly small thickness [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! 2. Systematically average discontinuous edge values call average_discontinuous_edge_values( N, edge_values ) @@ -127,9 +118,9 @@ subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, an endif ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -197,10 +188,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of finding edge values [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of finding edge values [H]. The default is h_neglect. ! Local variables integer :: i0, i1 logical :: monotonic ! boolean indicating whether the cubic is monotonic @@ -210,10 +201,9 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef real :: u0_l, u0_r ! Left and right edge values [A] real :: u1_l, u1_r ! Left and right edge slopes [A H-1] real :: slope ! The cell center slope [A H-1] - real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] + real :: hNeglect_edge ! Negligibly small thickness [H] - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = hNeglect_edge_dflt ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + hNeglect_edge = h_neglect ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge ! ----- Left boundary ----- i0 = 1 @@ -229,7 +219,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( h0 + h_neglect ) if ( abs(u1_r) > abs(slope) ) then u1_r = slope endif @@ -242,7 +232,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef ! edge value and slope by computing the parabola as determined by ! the right edge value and slope and the boundary cell average u0_l = 3.0 * u0 + 0.5 * h0*u1_r - 2.0 * u0_r - u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + hNeglect ) + u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + h_neglect ) ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the @@ -286,10 +276,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef b = ppoly_coef(i0,2) c = ppoly_coef(i0,3) d = ppoly_coef(i0,4) - u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 + u1_l = (b + 2*c + 3*d) / ( h0 + h_neglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( h1 + h_neglect ) if ( abs(u1_l) > abs(slope) ) then u1_l = slope endif @@ -302,7 +292,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef ! edge value and slope by computing the parabola as determined by ! the left edge value and slope and the boundary cell average u0_r = 3.0 * u1 - 0.5 * h1*u1_l - 2.0 * u0_l - u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + hNeglect ) + u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + h_neglect ) ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index c0c4516fe2..6d6afd3885 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -12,8 +12,6 @@ module PLM_functions public PLM_slope_wa public PLM_slope_cw -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness - contains !> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary @@ -195,7 +193,7 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u [A]. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h [H] @@ -208,15 +206,12 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) real :: almost_one ! A value that is slightly smaller than 1 [nondim] real, dimension(N) :: slp ! The first guess at the normalized tracer slopes [A] real, dimension(N) :: mslp ! The monotonized normalized tracer slopes [A] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) ! Loop on interior cells do k = 2,N-1 - slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), h_neglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled after monotonization. @@ -277,17 +272,14 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u [A]. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h [H] ! Local variables real :: slope ! retained PLM slope for a normalized cell width [A] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Extrapolate from 2 to 1 to estimate slope - slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) + slope = - PLM_extrapolate_slope( h(2), h(1), h_neglect, u(2), u(1) ) edge_values(1,1) = u(1) - 0.5 * slope edge_values(1,2) = u(1) + 0.5 * slope @@ -296,7 +288,7 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! Extrapolate from N-1 to N to estimate slope - slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) + slope = PLM_extrapolate_slope( h(N-1), h(N), h_neglect, u(N-1), u(N) ) edge_values(N,1) = u(N) - 0.5 * slope edge_values(N,2) = u(N) + 0.5 * slope diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index ef6841f635..c11ec6e741 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -15,13 +15,6 @@ module PPM_functions public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity -!> A tiny width that is so small that adding it to cell widths does not -!! change the value due to a computational representation. It is used -!! to avoid division by zero. -!! @note This is a dimensional parameter and should really include a unit -!! conversion. -real, parameter :: hNeglect_dflt = 1.E-30 - contains !> Builds quadratic polynomials coefficients from cell mean and edge values. @@ -31,7 +24,7 @@ subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answ real, dimension(N), intent(in) :: u !< Cell averages in arbitrary coordinates [A] real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -64,7 +57,7 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -190,7 +183,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle real, dimension(:), intent(in) :: u !< cell averages (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] ! Local variables @@ -204,9 +197,6 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ! the cell being worked on [A] real :: slope ! The normalized slope [A] real :: exp1, exp2 ! Temporary expressions [A2] - real :: hNeglect ! A negligibly small width used in cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary ----- i0 = 1 @@ -219,7 +209,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system b = ppoly_coef(i1,2) - u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, + u1_r = b *((h0+h_neglect)/(h1+h_neglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope @@ -273,7 +263,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle b = ppoly_coef(i0,2) c = ppoly_coef(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 - u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) + u1_l = u1_l * ((h1+h_neglect)/(h0+h_neglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index ef42fb9f01..418a4b47a2 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -9,8 +9,6 @@ module PQM_functions public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness - contains !> Reconstruction by quartic polynomials within each cell. @@ -24,7 +22,7 @@ subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_ real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -78,7 +76,7 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -98,12 +96,9 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat real :: sqrt_rho ! The square root of rho [A] real :: gradient1, gradient2 ! Normalized gradients [A] real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] - real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! Make discontinuous edge values monotonic (thru averaging) call check_discontinuous_edge_values( N, u, edge_values ) @@ -132,9 +127,9 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u_r = u(k+1) ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -272,8 +267,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + hNeglect ) - u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + hNeglect ) + u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + h_neglect ) + u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + h_neglect ) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -283,13 +278,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l - u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) + u1_r = 20.0 * (u_c - u0_l) / ( h_c + h_neglect ) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) + u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + h_neglect) endif @@ -297,8 +292,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge - u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + hNeglect) - u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + hNeglect) + u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + h_neglect) + u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + h_neglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -308,13 +303,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 - u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) + u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + h_neglect) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r - u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) + u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + h_neglect) endif @@ -506,7 +501,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] ! Local variables integer :: i0, i1 @@ -526,9 +521,6 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo real :: sqrt_rho ! The square root of rho [A] real :: gradient1, gradient2 ! Normalized gradients [A] real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] - real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary (TOP) ----- i0 = 1 @@ -541,7 +533,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! Compute real slope and express it w.r.t. local coordinate system ! within boundary cell - slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + hNeglect ) + slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + h_neglect ) slope = slope * h0 ! The right edge value and slope of the boundary cell are taken to be the @@ -550,12 +542,12 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo b = ppoly_coef(i1,2) u0_r = a ! edge value - u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) + u1_r = b / (h1 + h_neglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope if (u1_r /= 0.) then ! HACK by AJA - beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 + beta = 2.0 * ( u0_r - um ) / ( (h0 + h_neglect)*u1_r) - 1.0 else beta = 0. endif ! HACK by AJA @@ -574,10 +566,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! compute corresponding slope. if ( abs(um-u0_l) < abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) - u1_l = u1_l / (h0 + hNeglect) + u1_l = u1_l / (h0 + h_neglect) else u0_l = u_plm - u1_l = slope / (h0 + hNeglect) + u1_l = slope / (h0 + h_neglect) endif ! Monotonize quartic @@ -635,8 +627,8 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + hNeglect) - u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + hNeglect) + u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + h_neglect) + u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + h_neglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -646,13 +638,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l - u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) + u1_r = 20.0 * (um - u0_l) / ( h0 + h_neglect ) elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) + u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + h_neglect ) endif diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index ddc569e45e..1e5474770a 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -119,7 +119,7 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] !! to desired units for zInterface, perhaps GV%Z_to_H in which !! case this has units of [H Z-1 ~> nondim or kg m-3] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + real, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of !! edge value calculation [H ~> m or kg m-2] @@ -175,8 +175,8 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ ( p_col(nz) - p_col(1) ) enddo ! Remap from original h and T,S to get T,S_col_new - call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new, h_neglect, h_neglect_edge) - call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new) + call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new) call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) do k= 2,CS%nk @@ -225,7 +225,7 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly !! w.r.t. the interface target !! densities [R ~> kg m-3] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + real, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of !! edge value calculation [H ~> m or kg m-2] diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 3ed769f4e4..c967687dc8 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -105,7 +105,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same !! units as depth) [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose + real, intent(in) :: h_neglect !< A negligibly small width for the purpose !! of cell reconstructions [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose !! of edge value calculations [H ~> m or kg m-2] @@ -201,7 +201,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz), intent(in) :: S !< S for column [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces [Z ~> m] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [Z ~> m] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width @@ -272,9 +272,9 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ h1(k) = x1(k+1) - x1(k) enddo - call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp) ! Compute the deviation between two successive grids deviation = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 8aaeb12654..54cec45cba 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -18,15 +18,10 @@ module regrid_edge_values public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 -! The following parameters are used to avoid singular matrices for boundary -! extrapolation. The are needed only in the case where thicknesses vanish +! The following parameter is used to avoid singular matrices for boundary +! extrapolation. It is needed only in the case where thicknesses vanish ! to a small enough values such that the eigenvalues of the matrix can not ! be separated. -! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_edge_dflt = 1.e-10 !< The default value for cut-off minimum - !! thickness for sum(h) in edge value inversions -real, parameter :: hNeglect_dflt = 1.e-30 !< The default value for cut-off minimum - !! thickness for sum(h) in other calculations real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] contains @@ -47,20 +42,16 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Potentially modified edge values [A]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] or [A] real :: slope_x_h ! retained PLM slope times half grid step [A] - real :: hNeglect ! A negligible thickness [H]. logical :: use_2018_answers ! If true use older, less accurate expressions. integer :: k, km1, kp1 ! Loop index and the values to either side. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on cells to bound edge value do k = 1,N @@ -73,9 +64,9 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) slope_x_h = 0.0 if (use_2018_answers) then - sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + hNeglect ) - sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + hNeglect ) - sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + hNeglect ) + sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + h_neglect ) + sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + h_neglect ) + sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + h_neglect ) ! The limiter is used in the local coordinate system to each cell, so for convenience store ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) @@ -225,7 +216,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -248,16 +239,10 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(4) :: B ! The right hand side of the system to solve for C [A H] real, dimension(4) :: C ! The coefficients of a fit polynomial in units that vary ! with the index (j) as [A H^(j-1)] - real :: hNeglect ! A negligible thickness in the same units as h [H]. integer :: i, j logical :: use_2018_answers ! If true use older, less accurate expressions. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - else - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on interior cells do i = 3,N-1 @@ -270,9 +255,9 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Avoid singularities when consecutive pairs of h vanish if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then if (use_2018_answers) then - h_min = hMinFrac*max( hNeglect, h0+h1+h2+h3 ) + h_min = hMinFrac*max( h_neglect, h0+h1+h2+h3 ) else - h_min = hMinFrac*max( hNeglect, (h0+h1)+(h2+h3) ) + h_min = hMinFrac*max( h_neglect, (h0+h1)+(h2+h3) ) endif h0 = max( h_min, h(i-2) ) h1 = max( h_min, h(i-1) ) @@ -307,7 +292,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Determine first two edge values if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + h_min = max( h_neglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 1,4 dx = max(h_min, h(i) ) @@ -322,7 +307,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell @@ -333,7 +318,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Determine two edge values of the last cell if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + h_min = max( h_neglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 1,4 @@ -351,7 +336,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values @@ -384,11 +369,10 @@ subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] ! Local variables real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] - real :: hNeglect ! A negligible thickness in the same units as h [H] real :: da ! Difference between the unlimited scalar edge value estimates [A] real :: a6 ! Scalar field differences that are proportional to the curvature [A] real :: slk, srk ! Differences between adjacent cell averages of scalars [A] @@ -403,10 +387,8 @@ subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. integer :: k - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Set the thicknesses for very thin layers to some minimum value. - do k=1,N ; dp(k) = max(h(k), hNeglect) ; enddo + do k=1,N ; dp(k) = max(h(k), h_neglect) ; enddo !compute grid metrics do k=2,N @@ -494,7 +476,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -524,15 +506,9 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A] tri_x ! tridiagonal system (solution vector) [A] - real :: hNeglect ! A negligible thickness [H] logical :: use_2018_answers ! If true use older, less accurate expressions. use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) - if (use_2018_answers) then - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - else - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif ! Loop on cells (except last one) do i = 1,N-1 @@ -542,8 +518,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) h1 = h(i+1) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNeglect - h1 = hNeglect + h0 = h_neglect + h1 = h_neglect endif ! Auxiliary calculations @@ -562,8 +538,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_d(i+1) = 1.0 else ! Use expressions with less sensitivity to roundoff ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) + h0 = max(h(i), h_neglect) + h1 = max(h(i+1), h_neglect) ! The 1e-12 here attempts to balance truncation errors from the differences of ! large numbers against errors from approximating thin layers as non-vanishing. if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 @@ -587,7 +563,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Boundary conditions: set the first boundary value if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + h_min = max( h_neglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 1,4 dx = max(h_min, h(i) ) @@ -601,7 +577,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(1) = Csys(1) ! Set the first edge value. @@ -611,7 +587,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Boundary conditions: set the last boundary value if (use_2018_answers) then - h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + h_min = max( h_neglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i=1,4 dx = max(h_min, h(N-4+i) ) @@ -629,7 +605,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(N+1) = Csys(1) ! Set the last edge value @@ -806,7 +782,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -837,12 +813,10 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A H-1] tri_x ! tridiagonal system (solution vector) [A H-1] - real :: hNeglect ! A negligible thickness [H]. real :: hNeglect3 ! hNeglect^3 [H3]. logical :: use_2018_answers ! If true use older, less accurate expressions. - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect3 = hNeglect**3 + hNeglect3 = h_neglect**3 use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on cells (except last one) @@ -875,8 +849,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_b(i+1) = a * u(i) + b * u(i+1) else ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) + h0 = max(h(i), h_neglect) + h1 = max(h(i+1), h_neglect) I_h = 1.0 / (h0 + h1) h0 = h0 * I_h ; h1 = h1 * I_h @@ -917,7 +891,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope @@ -945,7 +919,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + do i=1,4 ; dz(i) = max(h_neglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) @@ -980,7 +954,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! ----------------------------------------------------------------------------- @@ -1021,7 +995,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2 ! Squares of thicknesses [H2] real :: h1_3, h2_3 ! Cubes of thicknesses [H3] real :: h1_4, h2_4 ! Fourth powers of thicknesses [H4] @@ -1045,12 +1018,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real :: h_Min_Frac = 1.0e-4 ! A minimum fractional thickness [nondim] integer :: i, k ! loop indexes - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on cells (except the first and last ones) do k = 2,N-2 ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + hMin = max(h_neglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) @@ -1091,7 +1062,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + hMin = max(h_neglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) @@ -1147,7 +1118,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + hMin = max(h_neglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) @@ -1255,7 +1226,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) real, dimension(N), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index !! is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, intent(in) :: h_neglect !< A negligibly small width [H] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables @@ -1263,7 +1234,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] real :: alpha, beta ! stencil coefficients [nondim] @@ -1286,12 +1256,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_x ! trid. system (unknowns vector) [A] integer :: i, k ! loop indexes - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on interior cells do k = 2,N-2 ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + hMin = max(h_neglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) @@ -1329,7 +1297,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) ! Use a right-biased stencil for the second row, as described in Eq. (49) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) + hMin = max(h_neglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) @@ -1364,7 +1332,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary - hMin = max( hNeglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) + hMin = max( h_neglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(i) ) @@ -1386,7 +1354,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) ! Use a left-biased stencil for the second to last row, as described in Eq. (50) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + hMin = max(h_neglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) @@ -1421,7 +1389,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary - hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) + hMin = max( h_neglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(N+1-i) ) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index b3100fe8ae..6e0be9ebba 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -87,15 +87,19 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial [A H-1] real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial [A] integer, intent(inout) :: degree !< The degree of the polynomials - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations [H] !! in the same units as h0. ! Local variables + real :: h_neg_edge ! A negligibly small width for the purpose of edge value + ! calculations in the same units as h0 [H] logical :: extrapolate + h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge + ! Reset piecewise polynomials ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 @@ -117,7 +121,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif @@ -129,7 +133,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif @@ -148,7 +152,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_CW ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neg_edge ) call PPM_monotonicity( n0, densities, ppoly0_E ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then @@ -167,7 +171,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -185,7 +189,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -203,13 +207,13 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect, h_neglect_edge ) + ppoly0_coefs, h_neglect, h_neg_edge ) endif else degree = DEGREE_1 @@ -223,7 +227,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -243,7 +247,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -263,7 +267,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neg_edge, answer_date=CS%answer_date ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) @@ -335,7 +339,7 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H] real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width diff --git a/src/ALE/remapping_attic.F90 b/src/ALE/remapping_attic.F90 index be20a27466..ab345dc53e 100644 --- a/src/ALE/remapping_attic.F90 +++ b/src/ALE/remapping_attic.F90 @@ -28,11 +28,6 @@ module remapping_attic ! outside of the range 0 to 1. #define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be - !! added to thicknesses in a denominator without - !! changing the numerical result, except where - !! a division by zero would otherwise occur. - contains !> Compare two summation estimates of positive data and judge if due to more @@ -83,7 +78,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] integer, intent(in) :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H]. ! Local variables @@ -132,7 +127,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] real, dimension(:), & optional, intent(out) :: h1 !< Target grid widths (size n1) [H] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H]. ! Local variables @@ -181,7 +176,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & ! hFlux is the positive width of the remapped volume hFlux = abs(dx1(iTarget+1)) call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hFlux, uAve, jStart, xStart ) + xL, xR, hFlux, uAve, jStart, xStart, h_neglect ) ! uAve is the average value of u, independent of sign of dx1 fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 @@ -218,7 +213,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, !< On exit, contains index of last cell used real, intent(inout) :: xStart !< The left edge position of cell jStart [H] !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [H] ! Local variables @@ -232,11 +227,8 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! (notionally xR - xL) which differs due to roundoff [H]. real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] - real :: hNeglect ! A negligible thickness in the same units as h [H] real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - q = -1.E30 x0jLl = -1.E30 x0jRl = -1.E30 @@ -288,7 +280,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) else ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) + xi0 = xL / ( h0(jL) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) select case ( method ) case ( INTEGRATION_PCM ) @@ -347,11 +339,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! ! Determine normalized coordinates #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) #else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) #endif hAct = h0(jL) * ( xi1 - xi0 ) @@ -403,9 +395,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! Integrate from xL up to right boundary of cell jL #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) #else - xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) + xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) #endif xi1 = 1.0 @@ -449,9 +441,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + h_neglect ) ) ) #else - xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) + xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) #endif hAct = hAct + h0(jR) * ( xi1 - xi0 ) @@ -568,8 +560,8 @@ logical function remapping_attic_unit_tests(verbose) v = verbose answer_date = 20190101 ! 20181231 - h_neglect = hNeglect_dflt - h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + h_neglect = 1.0E-30 + h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' remapping_attic_unit_tests = .false. ! Normally return false diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b696213e1b..638ffada32 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -113,6 +113,7 @@ module MOM use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields +use MOM_open_boundary, only : open_boundary_setup_vert use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init use MOM_porous_barriers, only : porous_barrier_CS @@ -2652,6 +2653,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + ! Finish OBC configuration that depend on the vertical grid + call open_boundary_setup_vert(GV, US, OBC_in) + ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. if (CS%rotate_index) then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index efb1bc69ab..68e1a03669 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -41,6 +41,7 @@ module MOM_open_boundary public open_boundary_apply_normal_flow public open_boundary_config +public open_boundary_setup_vert public open_boundary_init public open_boundary_query public open_boundary_end @@ -346,7 +347,10 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only + type(remapping_CS), pointer :: remap_z_CS=> NULL() !< ALE remapping control structure for + !! z-space data on segments + type(remapping_CS), pointer :: remap_h_CS=> NULL() !< ALE remapping control structure for + !! thickness-based fields on segments type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs in units of !! grid points per timestep [nondim] @@ -382,6 +386,11 @@ module MOM_open_boundary !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + logical :: check_reconstruction !< Flag for remapping to run checks on reconstruction + logical :: check_remapping !< Flag for remapping to run internal checks + logical :: force_bounds_in_subcell !< Flag for remapping to hide overshoot using bounds + logical :: om4_remap_via_sub_cells !< If true, use the OM4 remapping algorithm + character(40) :: remappingScheme !< String selecting the vertical remapping scheme type(group_pass_type) :: pass_oblique !< Structure for group halo pass end type ocean_OBC_type @@ -425,7 +434,6 @@ module MOM_open_boundary !> and ALE_init. Therefore segment data are not fully initialized !> here. The remainder of the segment data are initialized in a !> later call to update_open_boundary_data - subroutine open_boundary_config(G, US, param_file, OBC) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -667,23 +675,23 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", OBC%check_remapping, & "If true, the results of remapping are checked for "//& "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & default=.false.) - call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", OBC%force_bounds_in_subcell, & "If true, the values on the intermediate grid used for remapping "//& "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.,do_not_log=.true.) @@ -696,17 +704,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) - call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, & "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& "We recommend setting this option to false.", default=.true.) - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) - endif ! OBC%number_of_segments > 0 ! Safety check @@ -729,6 +731,41 @@ subroutine open_boundary_config(G, US, param_file, OBC) end subroutine open_boundary_config +!> Setup vertical remapping for open boundaries +subroutine open_boundary_setup_vert(GV, US, OBC) + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] + + if (associated(OBC)) then + if (OBC%number_of_segments > 0) then + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + allocate(OBC%remap_z_CS) + call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) + allocate(OBC%remap_h_CS) + call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif + endif + +end subroutine open_boundary_setup_vert + !> Allocate space for reading OBC data from files. It sets up the required vertical !! remapping. In the process, it does funky stuff with the MPI processes. subroutine initialize_segment_data(G, GV, US, OBC, PF) @@ -1973,6 +2010,8 @@ subroutine open_boundary_dealloc(OBC) if (allocated(OBC%cff_normal_v)) deallocate(OBC%cff_normal_v) if (allocated(OBC%tres_x)) deallocate(OBC%tres_x) if (allocated(OBC%tres_y)) deallocate(OBC%tres_y) + if (associated(OBC%remap_z_CS)) deallocate(OBC%remap_z_CS) + if (associated(OBC%remap_h_CS)) deallocate(OBC%remap_h_CS) deallocate(OBC) end subroutine open_boundary_dealloc @@ -3867,7 +3906,6 @@ 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 :: dz_neglect, dz_neglect_edge ! Small thicknesses [Z ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3880,14 +3918,6 @@ 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 (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 - elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - if (OBC%number_of_segments >= 1) then call thickness_to_dz(h, tv, dz, G, GV, US) call pass_var(dz, G%Domain) @@ -4176,25 +4206,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j)>0.) then dz_stack(:) = dz(i+ishift,j,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCu(I,j+1)>0.) then dz_stack(:) = dz(i+ishift,j+1,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4206,11 +4233,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) net_dz_int = sum( dz(i+ishift,j,:) ) scl_fac = net_dz_int / net_dz_src - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & - GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif enddo endif @@ -4226,25 +4252,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here dz_stack(:) = 0.5*(dz(i,j+jshift,:) + dz(i+1,j+jshift,:)) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i,J)>0.) then dz_stack(:) = dz(i,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) elseif (G%mask2dCv(i+1,J)>0.) then dz_stack(:) = dz(i+1,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) endif enddo else @@ -4256,11 +4279,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) net_dz_int = sum( dz(i,j+jshift,:) ) scl_fac = net_dz_int / net_dz_src - call remapping_core_h(OBC%remap_CS, & + call remapping_core_h(OBC%remap_z_CS, & segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & - GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & - dz_neglect, dz_neglect_edge) + GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) endif enddo endif @@ -5528,7 +5550,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] real :: I_scale ! The inverse of the scaling factor for the tracers. ! For salinity the units would be [ppt S-1 ~> 1]. - real :: h_neglect ! Tiny thickness used in remapping [H ~> m or kg m-2] logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. integer :: i, j, k, m, n, ntr, nz @@ -5536,7 +5557,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) nz = GV%ke ntr = OBC%ntr - h_neglect = GV%H_subroundoff if (.not.present(PCM_cell)) PCM(:) = .false. @@ -5566,11 +5586,10 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + PCM_cell=PCM) else - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & - h_neglect, h_neglect) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0? @@ -5584,8 +5603,8 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & + PCM_cell=PCM) do k=1,nz segment%rx_norm_rad(I,j,k) = r_norm_col(k) @@ -5594,14 +5613,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%rx_norm_obl(I,j,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%ry_norm_obl(I,j,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%cff_normal(I,j,:) = rxy_col(:) do k=1,nz @@ -5634,11 +5653,10 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + PCM_cell=PCM) else - call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & - h_neglect, h_neglect) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column) endif ! Possibly underflow any very tiny tracer concentrations to 0? @@ -5652,8 +5670,8 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & + PCM_cell=PCM) do k=1,nz segment%ry_norm_rad(i,J,k) = r_norm_col(k) @@ -5662,14 +5680,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then - call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%rx_norm_obl(i,J,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%ry_norm_obl(i,J,:) = rxy_col(:) - call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & - h_neglect, h_neglect, PCM_cell=PCM) + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & + PCM_cell=PCM) segment%cff_normal(i,J,:) = rxy_col(:) do k=1,nz @@ -5861,10 +5879,14 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%rx_max = OBC_in%rx_max OBC%OBC_pe = OBC_in%OBC_pe - ! remap_CS is set up by initialize_segment_data, so we copy the fields here. - if (ASSOCIATED(OBC_in%remap_CS)) then - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + ! remap_z_CS and remap_h_CS are set up by initialize_segment_data, so we copy the fields here. + if (ASSOCIATED(OBC_in%remap_z_CS)) then + allocate(OBC%remap_z_CS) + OBC%remap_z_CS = OBC_in%remap_z_CS + endif + if (ASSOCIATED(OBC_in%remap_h_CS)) then + allocate(OBC%remap_h_CS) + OBC%remap_h_CS = OBC_in%remap_h_CS endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 705bb6e535..677fdfe6dc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1859,7 +1859,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0) .or. & (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then - call wave_speed_init(CS%wave_speed, remap_answer_date=remap_answer_date, & + call wave_speed_init(CS%wave_speed, GV, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & wave_speed_tol=wave_speed_tol, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 8ee271f315..1c508ec490 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -51,7 +51,9 @@ module MOM_wave_speed !! are simply reported as 0 [L T-1 ~> m s-1]. A non-negative !! value must be specified via a call to wave_speed_init for !! the subroutine wave_speeds to be used (but not wave_speed). - type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic + type(remapping_CS) :: remap_2018_CS !< Used for vertical remapping when calculating equivalent barotropic + !! mode structure for answer dates below 20190101. + type(remapping_CS) :: remap_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. integer :: remap_answer_date = 99991231 !< The vintage of the order of arithmetic and expressions to use !! for remapping. Values below 20190101 recover the remapping @@ -674,13 +676,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N endif if (CS%remap_answer_date < 20190101) then - call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + call remapping_core_h(CS%remap_2018_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:)) else - call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:)) endif endif else @@ -1357,9 +1357,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & - nz, h(i,j,:), modal_structure_fder(:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:)) ! write the wave structure do k=1,nz+1 @@ -1533,9 +1532,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s nz, h(i,j,:), modal_structure(:), .false.) ! for u (remap) onto all layers - call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & - nz, h(i,j,:), modal_structure_fder(:), & - GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(CS%remap_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:)) ! write the wave structure ! note that m=1 solves for 2nd mode,... @@ -1610,10 +1608,11 @@ subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed -subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & +subroutine wave_speed_init(CS, GV, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & remap_answer_date, better_speed_est, om4_remap_via_sub_cells, & min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over @@ -1657,10 +1656,18 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & c1_thresh=c1_thresh) - ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. - call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & + ! The following remapping is only used for wave_speed with pre-2019 answers. + if (CS%remap_answer_date < 20190101) & + call initialize_remapping(CS%remap_2018_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=1.0e-30*GV%m_to_H, h_neglect_edge=1.0e-10*GV%m_to_H) + + ! This is used in wave_speeds in all cases, and in wave_speed with newer answers. + call initialize_remapping(CS%remap_CS, 'PLM', boundary_extrapolation=.false., & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%remap_answer_date) + answer_date=CS%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) end subroutine wave_speed_init diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index e8e6a756e9..1151cd04b2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -313,7 +313,8 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & - answer_date=remap_cs%answer_date) + answer_date=remap_cs%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) remap_cs%initialized = .true. endif @@ -432,16 +433,9 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere ! Local variables real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids integer :: i, j ! Grid index - if (remap_cs%Z_based_coord) then - h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) - else - h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) - endif - nz_src = size(field,3) nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. @@ -453,14 +447,14 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(I,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do I=G%IscB,G%IecB h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(I,j,:)) enddo ; enddo endif elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -470,14 +464,14 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(i,J,:)) endif ; enddo ; enddo else do J=G%jscB,G%jecB ; do i=G%isc,G%iec h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + nz_dest, h_dest(:), remapped_field(i,J,:)) enddo ; enddo endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -485,14 +479,12 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere if (present(mask)) then do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & - nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & - h_neglect, h_neglect_edge) + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do i=G%isc,G%iec call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & - nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & - h_neglect, h_neglect_edge) + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:)) enddo ; enddo endif else diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e8efc7c71a..769d60d51d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -92,7 +92,7 @@ module MOM_state_initialization use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment -use MOM_regridding, only : set_dz_neglect +use MOM_regridding, only : set_dz_neglect, set_h_neglect use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer, homogenize_field use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd @@ -1189,7 +1189,13 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) if (use_remapping) then allocate(remap_CS) - call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true.) + if (remap_answer_date < 20190101) then + call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + h_neglect=1.0e-30*GV%m_to_H, h_neglect_edge=1.0e-10*GV%m_to_H) + else + call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif endif ! Find edge values of T and S used in reconstructions @@ -1204,10 +1210,9 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, & - min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & - tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & - z_tol=z_tolerance, remap_answer_date=remap_answer_date) + call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, min_thickness, & + tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), & + p_surf(i,j), h(i,j,:), remap_CS, z_tol=z_tolerance) enddo ; enddo end subroutine trim_for_ice @@ -1298,7 +1303,7 @@ end subroutine calc_sfc_displacement !> Adjust the layer thicknesses by removing the top of the water column above the !! depth where the hydrostatic pressure matches p_surf subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T_t, T_b, & - S, S_t, S_b, p_surf, h, remap_CS, z_tol, remap_answer_date) + S, S_t, S_b, p_surf, h, remap_CS, z_tol) integer, intent(in) :: nk !< Number of layers type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1318,10 +1323,6 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! if associated real, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. - integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and - !! expressions to use for remapping. Values below 20190101 - !! recover the remapping answers from 2018, while higher - !! values use more robust forms of the same remapping expressions. ! Local variables real, dimension(nk+1) :: e ! Top and bottom edge positions for reconstructions [Z ~> m] @@ -1332,11 +1333,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real :: z_out, e_top ! Interface height positions [Z ~> m] real :: min_dz ! The minimum thickness in depth units [Z ~> m] real :: dh_surf_rem ! The remaining thickness to remove in non-Bousinesq mode [H ~> kg m-2] - logical :: answers_2018 integer :: k - answers_2018 = .true. ; if (present(remap_answer_date)) answers_2018 = (remap_answer_date < 20190101) - ! Keep a copy of the initial thicknesses in reverse order to use in remapping do k=1,nk ; h0(k) = h(nk+1-k) ; enddo @@ -1407,13 +1405,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T0(k) = T(nk+1-k) h1(k) = h(nk+1-k) enddo - if (answers_2018) then - call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) - call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) - else - call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, GV%H_subroundoff, GV%H_subroundoff) - call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, GV%H_subroundoff, GV%H_subroundoff) - endif + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1) do k=1,nk S(k) = S1(nk+1-k) T(k) = T1(nk+1-k) @@ -2758,8 +2751,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the target grid (and set the model thickness to it) call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS + if (remap_general) then + dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) + else + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + endif call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) ! Now remap from source grid to target grid, first setting reconstruction parameters if (remap_general) then @@ -2774,9 +2773,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just deallocate( dz_interface ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date ) + old_remap=remap_old_alg ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date ) + old_remap=remap_old_alg ) else ! This is the old way of initializing to z* coordinates only allocate( hTarget(nz) ) @@ -2799,11 +2798,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpT1dIn, dz, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + old_remap=remap_old_alg) call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpS1dIn, dz, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg, answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + old_remap=remap_old_alg) if (GV%Boussinesq .or. GV%semi_Boussinesq) then ! This is a simple conversion of the target grid to thickness units that is not @@ -3106,9 +3103,17 @@ subroutine MOM_state_init_tests(G, GV, US, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) GV%H_to_m*h(:) + + ! For consistency with the usual call, add the following: + ! if (use_remapping) then + ! allocate(remap_CS) + ! call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true., & + ! h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + ! endif call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_H, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS, z_tol=z_tol) write(0,*) GV%H_to_m*h(:) + if (associated(remap_CS)) deallocate(remap_CS) end subroutine MOM_state_init_tests diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index bafa5d8c36..6e3da385ce 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -13,7 +13,7 @@ module MOM_tracer_initialization_from_Z use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer use MOM_interface_heights, only : dz_to_thickness_simple -use MOM_regridding, only : set_dz_neglect +use MOM_regridding, only : set_dz_neglect, set_h_neglect use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -93,9 +93,9 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] real :: dz_neglect ! A negligibly small vertical layer extent used in - ! remapping cell reconstructions [Z ~> m] + ! remapping cell reconstructions [Z ~> m] or [H ~> m or kg m-2] real :: dz_neglect_edge ! A negligibly small vertical layer extent used in - ! remapping edge value calculations [Z ~> m] + ! remapping edge value calculations [Z ~> m] or [H ~> m or kg m-2] logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE @@ -117,7 +117,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + call callTree_enter(trim(mdl)//"(), MOM_tracer_initialization_from_Z.F90") call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homog, & "If True, then horizontally homogenize the interpolated "//& @@ -178,9 +178,15 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ allocate( h1(kd) ) allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) - ! Set parameters for reconstructions + ! Set parameters for reconstructions in the right units + if (h_is_in_Z_units) then + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + else + dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) + endif call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie @@ -206,18 +212,15 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ enddo ; enddo if (h_is_in_Z_units) then - ! Because h is in units of [Z ~> m], dzSrc is already in the right units, but we need to - ! specify negligible thickness values with the right units. - dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) - call ALE_remap_scalar(remapCS, G, GV, kd, dzSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & - H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + ! Because h is in units of [Z ~> m], dzSrc is already in the right units. + call ALE_remap_scalar(remapCS, G, GV, kd, dzSrc, tr_z, h, tr, all_cells=.false.) else ! Equation of state data is not available, so a simpler rescaling will have to suffice, ! but it might be problematic in non-Boussinesq mode. GV_loc = GV ; GV_loc%ke = kd call dz_to_thickness_simple(dzSrc, hSrc, G, GV_loc, US) - call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date ) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false.) endif deallocate( hSrc ) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 9275555afc..9d7c5cf05a 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -55,7 +55,7 @@ module MOM_oda_driver_mod use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_regridding, only : regridding_CS, initialize_regridding -use MOM_regridding, only : regridding_main, set_regrid_params +use MOM_regridding, only : regridding_main, set_regrid_params, set_h_neglect use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit @@ -184,6 +184,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: bias_correction_file, inc_file integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -323,8 +324,12 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) default="ZSTAR", fail_if_missing=.false.) call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & do_not_log=.true., default=.true.) + call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells) + + h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge) + call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) call set_regrid_params(CS%regridCS, min_thickness=0.) isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed @@ -415,7 +420,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) real, dimension(SZI_(G),SZJ_(G),CS%nk) :: S ! Salinity on the analysis grid [S ~> ppt] integer :: i, j, m integer :: isc, iec, jsc, jec - 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 @@ -427,14 +431,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) call set_PElist(CS%filter_pelist) !call MOM_mesg('Setting prior') - if (CS%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 - 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 @@ -443,9 +439,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,:), h_neglect, h_neglect_edge) + CS%nk, CS%h(i,j,:), T(i,j,:)) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:), h_neglect, h_neglect_edge) + CS%nk, CS%h(i,j,:), S(i,j,:)) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -683,7 +679,6 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) !! DA [C T-1 ~> degC s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S_tend !< The salinity tendency adjustment from DA !! [S T-1 ~> ppt s-1] - real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (.not. associated(CS)) return if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return @@ -700,20 +695,12 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) S_tend = S_tend + CS%S_bc_tend endif - if (CS%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 - 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_tend(i,j,:), & - G%ke, h(i,j,:), T_tend_inc(i,j,:), h_neglect, h_neglect_edge) + G%ke, h(i,j,:), T_tend_inc(i,j,:)) call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S_tend(i,j,:), & - G%ke, h(i,j,:), S_tend_inc(i,j,:), h_neglect, h_neglect_edge) + G%ke, h(i,j,:), S_tend_inc(i,j,:)) enddo; enddo diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index 94d09554c2..ad3423cde5 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -144,6 +144,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re character(len=256) :: mesg character(len=64) :: remapScheme logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & @@ -239,8 +240,15 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! Call the constructor for remapping control structure !### Revisit this hard-coded answer_date. + if (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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + endif + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=20190101) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=20190101, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) end subroutine initialize_oda_incupd @@ -347,7 +355,6 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) integer :: i, j, k, is, ie, js, je, nz, nz_data 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] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -359,13 +366,6 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) if (CS%ncount /= 0.0) call MOM_error(FATAL,'calc_oda_increments: '// & 'CS%ncount should be 0.0 to get accurate increments.') - - if (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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - endif - ! get h_obs nz_data = CS%Inc(1)%nz_data allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) @@ -404,8 +404,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) 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) + nz_data, tmp_h(1:nz_data), tmp_val2) ! 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) @@ -417,8 +416,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) 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) + nz_data, tmp_h(1:nz_data), tmp_val2) ! 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) @@ -456,8 +454,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) 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) + nz_data, hu_obs(1:nz_data), tmp_val2) ! 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) @@ -492,8 +489,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) 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) + nz_data, hv_obs(1:nz_data), tmp_val2) ! 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) @@ -554,7 +550,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) integer :: isB, ieB, jsB, jeB ! integer :: ncount ! time step counter 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 @@ -578,12 +573,6 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) write(mesg,'(f10.8)') inc_wt if (is_root_pe()) call MOM_error(NOTE,"updating fields with weight inc_wt:"//trim(mesg)) - if (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%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - endif - ! get h_obs nz_data = CS%Inc(1)%nz_data allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) @@ -621,7 +610,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) 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) + nz, h(i,j,1:nz), tmp_val1) 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) @@ -633,8 +622,8 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) 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) + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & + nz, h(i,j,1:nz), tmp_val1) ! 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) @@ -680,7 +669,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) 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) + nz, hu(1:nz), tmp_val1) ! add increment to u-velocity on hu do k=1,nz u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) @@ -718,7 +707,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) 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) + nz, hv(1:nz), tmp_val1) ! add increment to v-velocity on hv do k=1,nz v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index f75707e581..786e8819eb 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -4022,7 +4022,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo ! Initialize the module that calculates the wave speeds. - call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh, & + call wave_speed_init(CS%wave_speed, GV, c1_thresh=IGW_c1_thresh, & om4_remap_via_sub_cells=om4_remap_via_sub_cells) end subroutine internal_tides_init diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e3979fe35a..e541cecdcb 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1613,7 +1613,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& "See REMAPPING_USE_OM4_SUBCELLS for details. "//& "We recommend setting this option to false.", default=.true.) - call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & + call wave_speed_init(CS%wave_speed, GV, use_ebt_mode=CS%Resoln_use_ebt, & mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 170265d27a..b69e800254 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -468,6 +468,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I character(len=40) :: mdl = "MOM_sponge" ! This module's name. real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=64) :: remapScheme @@ -559,9 +560,19 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure + if (CS%remap_answer_date >= 20190101) then + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + elseif (GV%Boussinesq) then + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + elseif (GV%semi_Boussinesq) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - answer_date=CS%remap_answer_date) + answer_date=CS%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then @@ -950,7 +961,6 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) ! edges in the input file [Z ~> m] real :: missing_value ! The missing value in the input data field [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] real :: sp_val_v ! Interpolation of sp_val to v-points, often a velocity in [L T-1 ~> m s-1] @@ -961,16 +971,6 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) Idt = 1.0/dt - if (CS%remap_answer_date >= 20190101) then - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - elseif (GV%Boussinesq) then - dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 - elseif (GV%semi_Boussinesq) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - if (CS%time_varying_sponges) then do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data @@ -1038,12 +1038,11 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo endif if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dz%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif !Backward Euler method if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) @@ -1189,10 +1188,10 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzu%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = CS%var_u%p(i,j,1:nz) !Backward Euler method @@ -1222,10 +1221,10 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) enddo if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%dz(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) else call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzv%p(1:nz_data,c), tmp_val2, & - CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + CS%nz, dz_col, tmp_val1) endif if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = CS%var_v%p(i,j,1:nz) !Backward Euler method diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 31f90cdcb1..5b57103078 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -602,7 +602,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di local_mixing_frac = CS%Gamma_itides, & depth_cutoff = CS%min_zbot_itides*US%Z_to_m) - call read_tidal_energy(G, US, tidal_energy_type, param_file, CS) + call read_tidal_energy(G, GV, US, tidal_energy_type, param_file, CS) !call closeParameterBlock(param_file) @@ -912,7 +912,7 @@ subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_in ! 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%H_subroundoff, GV%H_subroundoff) + GV%ke, h_m, tidal_qe_md) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. @@ -1571,8 +1571,9 @@ end subroutine tidal_mixing_h_amp ! TODO: move this subroutine to MOM_internal_tide_input module (?) !> This subroutine read tidal energy inputs from a file. -subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) +subroutine read_tidal_energy(G, GV, US, tidal_energy_type, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=20), intent(in) :: tidal_energy_type !< The type of tidal energy inputs to read type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle @@ -1606,7 +1607,7 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) enddo ; enddo deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 - call read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) + call read_tidal_constituents(G, GV, US, tidal_energy_file, param_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") end select @@ -1614,8 +1615,9 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) end subroutine read_tidal_energy !> This subroutine reads tidal input energy from a file by constituent. -subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) +subroutine read_tidal_constituents(G, GV, US, tidal_energy_file, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidal energy inputs type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle @@ -1700,7 +1702,8 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) ! initialize input remapping: call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & boundary_extrapolation=.false., check_remapping=CS%debug, & - answer_date=CS%remap_answer_date) + answer_date=CS%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) deallocate(tc_m2) deallocate(tc_s2) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index b6714148ea..6d8fe881d1 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -151,7 +151,8 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - check_reconstruction=.false., check_remapping=.false.) + check_reconstruction=.false., check_remapping=.false., & + h_neglect=CS%H_subroundoff, h_neglect_edge=CS%H_subroundoff) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & @@ -739,10 +740,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ allocate(khtr_ul_z(nk), source=0.0) ! remap tracer to dz_top - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & - 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) + 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(:)) ! thicknesses at velocity points & khtr_u at layer centers do k = 1,ke @@ -753,8 +752,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! remap khtr_ul to khtr_ul_z - call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:), & - CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:)) ! 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) @@ -855,15 +853,16 @@ 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., & - om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. - check_reconstruction=.true., check_remapping=.true.) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. CS%limiter=.false. CS%limiter_remap=.false. CS%hbd_nk = 2 + (2*2) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. + check_reconstruction=.true., check_remapping=.true., & + h_neglect=CS%H_subroundoff, h_neglect_edge=CS%H_subroundoff) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) allocate(CS%hbd_u_kmax(1,1), source=0) near_boundary_unit_tests = .false. From 3d37f13324fae35dea438940cb2570e0e763e055 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 3 Oct 2024 16:27:46 -0400 Subject: [PATCH 113/128] Change default of USE_POROUS_BARRIER to false * subroutine initialize_MOM * MOM_input in test cases --- .testing/tc0/MOM_input | 3 +++ .testing/tc1/MOM_input | 3 +++ .testing/tc2/MOM_input | 3 +++ .testing/tc3/MOM_input | 3 +++ .testing/tc4/MOM_input | 3 +++ src/core/MOM.F90 | 2 +- 6 files changed, 16 insertions(+), 1 deletion(-) diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index e4d1694e72..7a107486b2 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -13,6 +13,9 @@ ADIABATIC = True ! [Boolean] default = False ! true. This assumes that KD = KDML = 0.0 and that ! there is no buoyancy forcing, but makes the model ! faster by eliminating subroutine calls. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 8.64E+04 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 04204bd67f..098952ccc2 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -72,6 +72,9 @@ MIXEDLAYER_RESTRAT = True ! [Boolean] default = False ! If true, a density-gradient dependent re-stratifying ! flow is imposed in the mixed layer. ! This is only used if BULKMIXEDLAYER is true. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 900.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index e142c64ff8..c8aad58e92 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -75,6 +75,9 @@ MIXEDLAYER_RESTRAT = True ! [Boolean] default = False ! If true, a density-gradient dependent re-stratifying ! flow is imposed in the mixed layer. ! This is only used if BULKMIXEDLAYER is true. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 3600.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 6963feee98..6a1238ee96 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -72,6 +72,9 @@ NK = 10 ! [nondim] ENABLE_THERMODYNAMICS = False ! [Boolean] default = True ! If true, Temperature and salinity are used as state ! variables. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 120.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index c4ef8475a9..b985b8e082 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -4,6 +4,9 @@ USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 1200.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that is actually used will ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 638ffada32..655e3d162c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2313,7 +2313,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_POROUS_BARRIER", CS%use_porbar, & "If true, use porous barrier to constrain the widths "//& "and face areas at the edges of the grid cells. ", & - default=.true.) ! The default should be false after tests. + default=.false.) call get_param(param_file, "MOM", "BATHYMETRY_AT_VEL", bathy_at_vel, & "If true, there are separate values for the basin depths "//& "at velocity points. Otherwise the effects of topography "//& From 96a91f5b6b2f0a9734a01340eda31f0404c6a123 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 1 Nov 2024 16:04:56 -0400 Subject: [PATCH 114/128] Set truncation file handle check from < 0 to == -1 (#739) This patch replaces the `CS%[uv]_file < 0` checks with `CS%[uv]_file == -1`. FMS1 returns negative file handles for missing or otherwise error-prone files, but the FMS2 IO framework relies on `newunit=` to autogenerate handle IDs, which are always negative and cannot be used with checks for negative values. The check is replaced with equality with -1. `newunit` is guaranteed to never return -1 for a valid file, so this is a valid check for a missing file. It also lets us continue to use -1 as the initial (unopened) value. Behavior is compatible with `mpp_open()` output, so this can also be used with the FMS1 API. A better solution would be to introduce some validation function which is defined by each API, but there is not yet any need for such sophistication. --- src/diagnostics/MOM_PointAccel.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index ab3c104d0f..30f080382c 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -121,11 +121,11 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do_k(:) = .false. ! Open up the file for output if this is the first call. - if (CS%u_file < 0) then + if (CS%u_file == -1) then if (len_trim(CS%u_trunc_file) < 1) return call open_ASCII_file(CS%u_file, trim(CS%u_trunc_file), action=APPEND_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (CS%u_file < 0) then + if (CS%u_file == -1) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%u_trunc_file)//'.') return endif @@ -462,11 +462,11 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do_k(:) = .false. ! Open up the file for output if this is the first call. - if (CS%v_file < 0) then + if (CS%v_file == -1) then if (len_trim(CS%v_trunc_file) < 1) return call open_ASCII_file(CS%v_file, trim(CS%v_trunc_file), action=APPEND_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (CS%v_file < 0) then + if (CS%v_file == -1) then call MOM_error(NOTE, 'Unable to open file '//trim(CS%v_trunc_file)//'.') return endif From 88ee9dd2d1ad70b01c02d919815564b47b2a0bd4 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 31 Oct 2024 15:11:50 -0400 Subject: [PATCH 115/128] CI: Consolidate unit test rules, codecov pathfix This commit contains two changes to gcov report generation and codecov upload. 1. Separation of the file parser unit tests from the others was causing them to be exluded from report.cov.unit. This patch reworks the rules to replace MOM_file_parser_tests.F90.gcov with driver code, build/unit/test_%.F90.gcov. This does assume at all drivers will look the same (test_*.F90) but that part can be reworked if it ever becomes a problem in the future. Thanks to @adcroft for multiple suggestions in this PR. 2. Github appears to internally store all its repositories in another directory with the name as the repo (in this case MOM6/). Normally this is hidden to everyone, but it was causing some confusion with the codecov upload tool, and was unable to match the source code to the .gcov report. The .codecov.yml config file was modified to adjust for this path change, and should now correctly allow coverage to be reported alongside the file. (The GitHub Actions app likely makes this adjustment, but we need to do it manually since we upload directly to Codecov.io.) --- .codecov.yml | 3 +++ .github/workflows/coverage.yml | 14 ++++---------- .testing/Makefile | 11 ++++------- 3 files changed, 11 insertions(+), 17 deletions(-) diff --git a/.codecov.yml b/.codecov.yml index ae3b27aed3..838c421f66 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -8,3 +8,6 @@ coverage: default: threshold: 100% base: parent + +fixes: + - "MOM6/::" diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 8b3dc944bd..22b9e471bc 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -19,17 +19,11 @@ jobs: - uses: ./.github/actions/testing-setup - - name: Compile file parser unit tests - run: make -j build/unit/test_MOM_file_parser - - - name: Run file parser unit tests - run: make run.cov.unit - - - name: Compile unit testing + - name: Compile unit tests run: make -j build.unit - - name: Run (single processor) unit tests - run: make run.unit + - name: Run unit tests + run: make run.cov.unit - name: Report unit test coverage to CI run: make report.cov.unit @@ -40,7 +34,7 @@ jobs: run: make -j build/cov/MOM6 - name: Run coverage tests - run: make -j -k run.cov + run: make -k run.cov - name: Report coverage to CI run: make report.cov diff --git a/.testing/Makefile b/.testing/Makefile index 18687a1616..a8a5ea3e68 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -222,8 +222,6 @@ build.prof: $(foreach b,opt opt_target,$(BUILD)/$(b)/MOM6) # Compiler flags # .testing dependencies -# TODO: We should probably build TARGET with the FMS that it was configured -# to use. But for now we use the same FMS over all builds. FCFLAGS_DEPS = -I$(abspath $(DEPS)/include) LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" @@ -661,7 +659,7 @@ test.summary: # NOTE: Using file parser gcov report as a proxy for test completion .PHONY: run.cov.unit -run.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov +run.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) .PHONY: build.unit build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) @@ -702,6 +700,7 @@ $(WORK)/unit/%.out: $(BUILD)/unit/% @mkdir -p $(@D) cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out +# The file parser uses a separate rule to support two-core tests. $(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser if [ $(REPORT_COVERAGE) ]; then \ find $(BUILD)/unit -name *.gcda -exec rm -f '{}' \; ; \ @@ -721,15 +720,13 @@ $(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser cat p2.test_MOM_file_parser.err | tail -n 100 ; \ ) -# NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out -# TODO: Replace $(WORK)/unit/std.out with *.gcda? -$(BUILD)/unit/MOM_file_parser_tests.F90.gcov: $(WORK)/unit/test_MOM_file_parser.out +$(BUILD)/unit/test_%.F90.gcov: $(WORK)/unit/test_%.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; .PHONY: report.cov.unit -report.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov codecov +report.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) codecov ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/unit -f "*.gcov" -Z -n "Unit tests" \ > $(BUILD)/unit/codecov.out \ 2> $(BUILD)/unit/codecov.err \ From a6d27cf29931f8a5c175b3a047395a7766fd3a0b Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 23 Oct 2024 21:20:51 -0400 Subject: [PATCH 116/128] adding a constant mixing efficiency to internal tides --- .../lateral/MOM_internal_tides.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 786e8819eb..c7101ac6b7 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -146,6 +146,7 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] + real :: mixing_effic !< mixing efficiency [nondim] real :: En_sum !< global sum of energy for use in debugging, in MKS units [H Z2 T-2 L2 ~> m5 s-2 or J] real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] @@ -1653,7 +1654,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! layer diffusivity for processus if (h(i,j,k) >= CS%min_thick_layer_Kd) then TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) - Kd_leak_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + Kd_leak_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) else Kd_leak_lay(k) = 0. endif @@ -1675,7 +1676,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! layer diffusivity for processus if (h(i,j,k) >= CS%min_thick_layer_Kd) then TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) - Kd_Froude_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + Kd_Froude_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) else Kd_Froude_lay(k) = 0. endif @@ -1697,7 +1698,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! layer diffusivity for processus if (h(i,j,k) >= CS%min_thick_layer_Kd) then TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) - Kd_itidal_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + Kd_itidal_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) else Kd_itidal_lay(k) = 0. endif @@ -1719,7 +1720,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! layer diffusivity for processus if (h(i,j,k) >= CS%min_thick_layer_Kd) then TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) - Kd_slope_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + Kd_slope_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) else Kd_slope_lay(k) = 0. endif @@ -1741,7 +1742,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 ! layer diffusivity for processus if (h(i,j,k) >= CS%min_thick_layer_Kd) then TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) - Kd_quad_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + Kd_quad_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) else Kd_quad_lay(k) = 0. endif @@ -3539,6 +3540,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MINTHICK_TKE_TO_KD", CS%min_thick_layer_Kd, & "The minimum thickness allowed with TKE_to_Kd.", & units="m", default=1e-6, scale=GV%m_to_H) + call get_param(param_file, mdl, "ITIDES_MIXING_EFFIC", CS%mixing_effic, & + "Mixing efficiency for internal tides raytracing", & + units="nondim", default=0.2) call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & "Limiter for TKE_to_Kd.", & units="", default=1e9, scale=US%Z_to_m*US%s_to_T**2) From 76915fff2b4e04aeafab9466d27600cad9261c25 Mon Sep 17 00:00:00 2001 From: He Wang Date: Sun, 27 Oct 2024 11:14:38 -0400 Subject: [PATCH 117/128] Revert the change from VISC_REM_CONT_VEL_FIX This particular bugfix was proved to be unnecessary and therefore incorrectly added. Runtime parameter VISC_REM_BUG now controls two bugfixes, related to RK2 time stepping and barotropic vertical weight, which are valid. --- src/core/MOM_continuity_PPM.F90 | 49 +++++++-------------------------- 1 file changed, 10 insertions(+), 39 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 5fbf12a0d0..db60b2f0e4 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -64,9 +64,6 @@ module MOM_continuity_PPM !! continuity solver for use as the weights in the !! barotropic solver. Otherwise use the transport !! averaged areas. - logical :: visc_rem_hvel_fix = .False. !< If true, thickness at velocity points - !! h_[uv] (used by barotropic solver) is not multiplied - !! by visc_rem_[uv]. end type continuity_PPM_CS !> A container for loop bounds @@ -809,22 +806,12 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then - if (CS%visc_rem_hvel_fix) then - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) - else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) - endif + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) else - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) - else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) - endif + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) endif endif ; endif @@ -1709,22 +1696,12 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then - if (CS%visc_rem_hvel_fix) then - if (present(v_cor)) then - call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) - else - call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) - endif + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) else - if (present(v_cor)) then - call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) - else - call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) - endif + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) endif endif ; endif @@ -2713,7 +2690,6 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. - logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. CS%initialized = .true. @@ -2774,11 +2750,6 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, use the marginal face areas from the continuity "//& "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) - call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) - call get_param(param_file, mdl, "VISC_REM_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & - "If true, velocity cell thickness h_[uv] from the continuity solver "//& - "is not multiplied by visc_rem_[uv]. Default of this flag is set by "//& - "VISC_REM_BUG.", default=.False.) !, default=.not.visc_rem_bug) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) From dbb360197fd6c0a3f5ab2d51c10873f0c352d59c Mon Sep 17 00:00:00 2001 From: He Wang Date: Sun, 27 Oct 2024 16:13:00 -0400 Subject: [PATCH 118/128] Rename VISC_REM bugfix parameters VISC_REM_TIMESTEP_FIX -> VISC_REM_TIMESTEP_BUG VISC_REM_BT_WEIGHT_FIX -> VISC_REM_BT_WEIGHT_BUG The "signs" of the flags are flipped accordingly. --- src/core/MOM_barotropic.F90 | 13 ++++++------- src/core/MOM_dynamics_split_RK2.F90 | 27 +++++++++++++-------------- src/core/MOM_dynamics_split_RK2b.F90 | 28 ++++++++++++++-------------- 3 files changed, 33 insertions(+), 35 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0ac3e52a62..af2beca1fb 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -289,7 +289,7 @@ module MOM_barotropic logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed !! consistent with tidal self-attraction and loading !! used within the barotropic solver - logical :: wt_uv_fix !< If true, use a normalized wt_[uv] for vertical averages. + logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -1070,7 +1070,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem enddo ; enddo ; enddo - if (CS%wt_uv_fix) then + if (.not. CS%wt_uv_bug) then do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo do k=2,nz ; do j=js,je ; do I=is-1,ie Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) @@ -4652,11 +4652,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) - call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_FIX", CS%wt_uv_fix, & - "If true, use a normalized weight function for vertical averages of "//& - "baroclinic velocity and forcing. Default of this flag is set by "//& - "VISC_REM_BUG. This flag should be used with VISC_REM_TIMESTEP_FIX.", & - default=.not.visc_rem_bug) + call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", CS%wt_uv_bug, & + "If true, recover a bug in barotropic solver that uses an unnormalized weight "//& + "function for vertical averages of baroclinic velocity and forcing. Default "//& + "of this flag is set by VISC_REM_BUG.", default=visc_rem_bug) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index addfb0e212..f602b65240 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -178,7 +178,8 @@ module MOM_dynamics_split_RK2 logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. - logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs integer :: id_uold = -1, id_vold = -1 @@ -736,10 +737,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - if (CS%visc_rem_dt_fix) then - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) - else + if (CS%visc_rem_dt_bug) then call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) endif call cpu_clock_end(id_clock_vertvisc) @@ -1439,16 +1440,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p default=.false.) call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& - "for in three places. This parameter controls the defaults of three individual "//& - "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& - "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& - "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& - "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) - call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & - "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& - "predictor stage for the following continuity() call and btstep() call "//& - "in the corrector step. This flag should be used with "//& - "VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & + "If true, recover a bug that uses dt_pred rather than dt in "//& + "vertvisc_remnant() at the end of predictor stage for the following "//& + "continuity() and btstep() calls in the corrector step. Default of this flag "//& + "is set by VISC_REM_BUG", default=visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 9227ea57ed..87e46795b5 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -175,7 +175,8 @@ module MOM_dynamics_split_RK2b logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. - logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs ! integer :: id_uold = -1, id_vold = -1 @@ -754,10 +755,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - if (CS%visc_rem_dt_fix) then - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) - else + if (CS%visc_rem_dt_bug) then call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) endif call cpu_clock_end(id_clock_vertvisc) @@ -1355,16 +1356,15 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, default=.false.) call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& - "for in three places. This parameter controls the defaults of three individual "//& - "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& - "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& - "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& - "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) - call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & - "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& - "predictor stage for the following continuity() call and btstep() call "//& - "in the corrector step. Default of this flag is set by VISC_REM_BUG. "//& - "This flag should be used with VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & + "If true, recover a bug that uses dt_pred rather than dt in "//& + "vertvisc_remnant() at the end of predictor stage for the following "//& + "continuity() and btstep() calls in the corrector step. Default of this flag "//& + "is set by VISC_REM_BUG", default=visc_rem_bug) + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) From 13cc946fac445231fe4e10c92844e62d62ea2f05 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 29 Oct 2024 11:02:20 -0400 Subject: [PATCH 119/128] Replace hard-coded parameter Rrho0 with runtime parameter Max_Rrho_salt_fingers - Double diffusion code was updated to include runtime parameter for maximum density ratio, but it was never implemented in the actual calculation of the double diffusion diffusivities. It is now used in the calculation and Rrho0 is removed from the code. - The default value of Max_Rrho_salt_fingers is changed from 2.55 to 1.9 to avoid changing behavior from the old code. However, it should be updated to 2.55 and noted that it will change answers for any run with double diffusion enabled through MOM6. It does not affect the behavior of double diffusion enabled through CVMix. --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9a87b085a6..d15a364267 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1203,7 +1203,7 @@ end subroutine find_N2 !> This subroutine sets the additional diffusivities of temperature and !! salinity due to double diffusion, using the same functional form as is -!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates +!! used in MOM4.1, and taken from the appendix of Danabasoglu et al. (2006), which updates !! what was in Large et al. (1994). All the coefficients here should probably !! be made run-time variables rather than hard-coded constants. !! @@ -1246,8 +1246,6 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Kd_dd ! The dominant double diffusive diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: prandtl ! flux ratio for diffusive convection regime [nondim] - real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1273,8 +1271,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case - Rrho = min(alpha_dT / beta_dS, Rrho0) - diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) + Rrho = min(alpha_dT / beta_dS, CS%Max_Rrho_salt_fingers) + diff_dd = 1.0 - ((RRho-1.0)/(CS%Max_Rrho_salt_fingers-1.0)) Kd_dd = CS%Max_salt_diff_salt_fingers * diff_dd*diff_dd*diff_dd Kd_T_dd(i,K) = 0.7 * Kd_dd Kd_S_dd(i,K) = Kd_dd @@ -2541,7 +2539,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%double_diffusion) then call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & "Maximum density ratio for salt fingering regime.", & - default=2.55, units="nondim") + default=1.9, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) From 31a4d8b4576e4696b6add76fe1ef31638849e284 Mon Sep 17 00:00:00 2001 From: Alan Wallcraft Date: Fri, 8 Nov 2024 11:05:58 -0500 Subject: [PATCH 120/128] Add REMAPPING_SCHEME for OBC, ODA and SPONGE (#751) Most modules that use remapping have their own parameter e.g. Z_INIT_REMAPPING_SCHEME. However, OBC, ODA and SPONGE currently sliently use the primary ALE REMAPPING_SCHEME parameter. Added logged parameters OBC_REMAPPING_SCHEME, ODA_REMAPPING_SCHEME and SPONGE_REMAPPING_SCHEME to allow customization. All take REMAPPING_SCHEME as their default to maintain compatibility. For ODA, also added ODA_REMAPPING_USE_OM4_SUBCELLS that takes REMAPPING_USE_OM4_SUBCELLS as its default to maintain compatibility, and ODA_BOUNDARY_EXTRAP that takes BOUNDARY_EXTRAPOLATION as its default to maintain compatibility. Note that BOUNDARY_EXTRAPOLATION is a bug, it should have been REMAP_BOUNDARY_EXTRAP, but the former remains the default for compatibility. For SPONGE, also added SPONGE_BOUNDARY_EXTRAP that takes BOUNDARY_EXTRAPOLATION as its default to maintain compatibility. Note that BOUNDARY_EXTRAPOLATION is a bug, it should have been REMAP_BOUNDARY_EXTRAP, but the former remains the default for compatibility. Answers are unchanged, but there are new logged parameters. --- src/core/MOM_open_boundary.F90 | 9 ++++--- src/ocean_data_assim/MOM_oda_driver.F90 | 7 +++-- src/ocean_data_assim/MOM_oda_incupd.F90 | 20 +++++++++----- .../vertical/MOM_ALE_sponge.F90 | 26 ++++++++++--------- 4 files changed, 38 insertions(+), 24 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 68e1a03669..f89c8953ab 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -448,9 +448,8 @@ 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] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + logical :: check_remapping, force_bounds_in_subcell logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm - character(len=64) :: remappingScheme ! This include declares and sets the variable "version". # include "version_variable.h" @@ -676,10 +675,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, & + default=remappingDefaultScheme, do_not_log=.true.) + call get_param(param_file, mdl, "OBC_REMAPPING_SCHEME", OBC%remappingScheme, & "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& + "for OBC vertical remapping for all variables. "//& "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + trim(remappingSchemesDoc), default=OBC%remappingScheme) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 9d7c5cf05a..d620962222 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -245,7 +245,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, mdl, "INPUTDIR", inputdir) call get_param(PF, mdl, "ODA_REMAPPING_SCHEME", remap_scheme, & "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& + "for vertical remapping for all ODA variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default="PPM_H4") call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & @@ -324,7 +324,10 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) default="ZSTAR", fail_if_missing=.false.) call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & do_not_log=.true., default=.true.) - + call get_param(PF, mdl, "ODA_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ODA. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge) diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index ad3423cde5..f174bf14ad 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -25,6 +25,7 @@ module MOM_oda_incupd use MOM_grid, only : ocean_grid_type use MOM_io, only : vardesc, var_desc use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping +use MOM_remapping, only : remappingSchemesDoc use MOM_restart, only : register_restart_field, register_restart_pair, MOM_restart_CS use MOM_restart, only : restart_init, save_restart, query_initialized use MOM_spatial_means, only : global_i_mean @@ -184,22 +185,29 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re "use U,V increments.", & default=.true.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "ODA_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all ODA variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remapScheme) + !The default should be REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ODA_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "ODA_INCUPD_DATA_ONGRID", CS%incupdDataOngrid, & "When defined, the incoming oda_incupd data are "//& "assumed to be on the model horizontal grid " , & default=.true.) call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "ODA_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ODA. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) CS%nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index b69e800254..0dfead633c 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -215,16 +215,17 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all SPONGE variables.", default=remapScheme) + !This default should be from REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of SPONGE boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -495,15 +496,16 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "Apply sponges in u and v, in addition to tracers.", & default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used "//& - " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all SPONGE variables.", default=remapScheme) + !This default should be from REMAP_BOUNDARY_EXTRAP call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction "//& - "scheme is used within boundary cells rather "//& - "than PCM. E.g., if PPM is used for remapping, a "//& - "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_BOUNDARY_EXTRAP", bndExtrapolation, & + "If true, values at the interfaces of SPONGE boundary cells are "//& + "extrapolated instead of piecewise constant", default=bndExtrapolation) call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_dz_mask, & "An input file thickness below which the target values with "//& "time-varying sponges are replaced by the value above.", & From 7a9adbcac5259be8fde7b22dcc2cc06b8d3e8283 Mon Sep 17 00:00:00 2001 From: Wenda Zhang <42078272+Wendazhang33@users.noreply.github.com> Date: Wed, 13 Nov 2024 14:11:21 -0500 Subject: [PATCH 121/128] Add SQG vertical structure to eddy diffusivities (#738) Added SQG vertical structure in Varmix to provide vertical profile for diffusivities - added function calc_sqg_struct in MOM_lateral_mixing_coeffs to compute sqg_struct - added sqg_expo to set the exponent of sqg_struct - to use sqg_struct for the backscatter, set BS_use_sqg=true, sqg_expo>0., and BS_EBT_power=0. - if SQG_USE_MEKE=True, use the eddy length scale from MEKE to compute sqg_struct - added eddy length scale Le in MEKE if SQG_USE_MEKE=True - added MEKE%Le into restart file if SQG_USE_MEKE=True - added MEKE in Varmix - registered N2_u and N2_v diagnostics when SQG_EXPO>0 (cherry picked from commit 6d3df0541c33d6f6d1f9fcb695f1a1eb961ec1b3) * Compute vertical structures for khth, khtr, backscatter, and kdgl90 all in VarMix - Vertical structures including khth_struct, khtr_struct, BS_struct, and kdgl90_struct are now computed in VarMix - Each diffusivity/viscosity have two vertical structure options, equivalent barotropic (EBT) and surface quasigeostrophic (SQG) mode structures - KHTH_USE_EBT_STRUCT, KHTR_USE_EBT_STRUCT, KDGL90_USE_EBT_STRUCT and BS_EBT_POWER parameters, which already existed, still control whether to use the EBT structure for khth, khtr, kdgl90, and backscatter, respectively - Added KHTH_USE_SQG_STRUCT, KHTR_USE_SQG_STRUCT, KDGL90_USE_SQG_STRUCT and BS_USE_SQG parameters to control whether to use the SQG structure for khth, khtr, kdgl90, and backscatter, respectively - If neither EBT nor SQG is called, no vertical structure will be used for that diffusivity/viscosity - An error will be called if both EBT and SQG structures are called for the same diffusivity/viscosity - Added dt as an input of calc_resoln_function. dt is needed for calc_sqg_struct called in calc_resoln_function Bug fixes - Changed ()**0.5 to sqrt in sqg_struct, which solves the dimension error - Added if statement for using BS_struct in MOM_hor_visc - Added if statement for CS%sqg_struct<=0. - Changed the subroundoff of Coriolis parameter to 1e-40 in calc_sqg_struct - Changed parameter BS_USE_SQG to BS_USE_SQG_STRUCT --------- Co-authored-by: Alistair Adcroft --- src/core/MOM.F90 | 6 +- src/parameterizations/lateral/MOM_MEKE.F90 | 34 ++- .../lateral/MOM_MEKE_types.F90 | 1 + .../lateral/MOM_hor_visc.F90 | 66 +++-- .../lateral/MOM_lateral_mixing_coeffs.F90 | 253 +++++++++++++++++- .../lateral/MOM_thickness_diffuse.F90 | 14 +- .../vertical/MOM_vert_friction.F90 | 16 +- src/tracer/MOM_neutral_diffusion.F90 | 32 ++- src/tracer/MOM_tracer_hor_diff.F90 | 35 +-- 9 files changed, 379 insertions(+), 78 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 655e3d162c..7ee90d746a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -751,7 +751,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%VarMix%use_variable_mixing) then call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) - call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt) call calc_depth_function(G, CS%VarMix) call disable_averaging(CS%diag) endif @@ -1899,7 +1899,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif @@ -1926,7 +1926,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 9ebe8ae734..4bac09b7cc 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -124,6 +124,7 @@ module MOM_MEKE logical :: debug !< If true, write out checksums of data for debugging integer :: eke_src !< Enum specifying whether EKE is stepped forward prognostically (default), !! read in from a file, or inferred via a neural network + logical :: sqg_use_MEKE !< If True, use MEKE%Le for the SQG vertical structure. type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 @@ -400,6 +401,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call hchksum(LmixScale, 'MEKE LmixScale', G%HI, unscale=US%L_to_m) endif + if (allocated(MEKE%Le)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = LmixScale(i,j) + enddo ; enddo + endif + ! Aggregate sources of MEKE (background, frictional and GM) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -757,7 +765,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif - if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) then + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au) & + .or. allocated(MEKE%Le)) then call cpu_clock_begin(CS%id_clock_pass) call do_group_pass(CS%pass_Kh, G%Domain) call cpu_clock_end(CS%id_clock_pass) @@ -1425,6 +1434,9 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "computing beta in the expression of Rhines scale. Use 1 if full "//& "topographic beta effect is considered; use 0 if it's completely ignored.", & units="nondim", default=0.0) + call get_param(param_file, mdl, "SQG_USE_MEKE", CS%sqg_use_MEKE, & + "If true, the eddy scale of MEKE is used for the SQG vertical structure ",& + default=.false.) ! Nonlocal module parameters call get_param(param_file, mdl, "CDRAG", cdrag, & @@ -1531,6 +1543,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME CS%id_clock_pass = cpu_clock_id('(Ocean continuity halo updates)', grain=CLOCK_ROUTINE) + ! Detect whether this instance of MEKE_init() is at the beginning of a run ! or after a restart. If at the beginning, we will initialize MEKE to a local ! equilibrium. @@ -1538,6 +1551,12 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (coldStart) CS%initialize = .false. if (CS%initialize) call MOM_error(WARNING, & "MEKE_init: Initializing MEKE with a local equilibrium balance.") + if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS) .and. allocated(MEKE%Le)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = sqrt(G%areaT(i,j)) + enddo ; enddo + endif ! Set up group passes. In the case of a restart, these fields need a halo update now. if (allocated(MEKE%MEKE)) then @@ -1548,8 +1567,10 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (allocated(MEKE%Kh)) call create_group_pass(CS%pass_Kh, MEKE%Kh, G%Domain) if (allocated(MEKE%Ku)) call create_group_pass(CS%pass_Kh, MEKE%Ku, G%Domain) if (allocated(MEKE%Au)) call create_group_pass(CS%pass_Kh, MEKE%Au, G%Domain) + if (allocated(MEKE%Le)) call create_group_pass(CS%pass_Kh, MEKE%Le, G%Domain) - if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) & + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au) & + .or. allocated(MEKE%Le)) & call do_group_pass(CS%pass_Kh, G%Domain) end function MEKE_init @@ -1839,6 +1860,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] logical :: Use_KH_in_MEKE logical :: useMEKE + logical :: sqg_use_MEKE integer :: isd, ied, jsd, jed ! Determine whether this module will be used @@ -1853,6 +1875,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) 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) + sqg_use_MEKE = .false. ; call read_param(param_file,"SQG_USE_MEKE", sqg_use_MEKE) if (.not. useMEKE) return @@ -1884,6 +1907,12 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, 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 (sqg_use_MEKE) then + allocate(MEKE%Le(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Le, "MEKE_Le", .false., restart_CS, & + longname="Eddy length scale from Mesoscale Eddy Kinetic Energy", & + units="m", conversion=US%L_to_m) + endif if (Use_Kh_in_MEKE) then allocate(MEKE%Kh_diff(isd:ied,jsd:jed), source=0.0) call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & @@ -1918,6 +1947,7 @@ subroutine MEKE_end(MEKE) if (allocated(MEKE%mom_src_bh)) deallocate(MEKE%mom_src_bh) if (allocated(MEKE%GM_src)) deallocate(MEKE%GM_src) if (allocated(MEKE%MEKE)) deallocate(MEKE%MEKE) + if (allocated(MEKE%Le)) deallocate(MEKE%Le) end subroutine MEKE_end !> \namespace mom_meke diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index a95578848d..38bdd72452 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -24,6 +24,7 @@ module MOM_MEKE_types !! backscatter from unresolved eddies (see Jansen and Held, 2014). real, allocatable :: Au(:,:) !< The MEKE-derived lateral biharmonic viscosity !! coefficient [L4 T-1 ~> m4 s-1]. + real, allocatable :: Le(:,:) !< Eddy length scale [L m] ! Parameters real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 56a359857f..fa5bb40577 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -446,6 +446,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, logical :: use_MEKE_Ku logical :: use_MEKE_Au logical :: use_cont_huv + logical :: use_kh_struct integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -502,6 +503,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true. if (allocated(MEKE%mom_src)) find_FrictWork = .true. + use_kh_struct = allocated(VarMix%BS_struct) backscat_subround = 0.0 if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. & (MEKE%backscatter_Ro_Pow /= 0.0)) & @@ -663,7 +665,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & - !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & + !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, use_kh_struct, & !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & @@ -1181,14 +1183,26 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (which might be negative) - if (CS%res_scale_MEKE) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k) - enddo ; enddo + if (use_kh_struct) then + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + endif else - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) - enddo ; enddo + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) + enddo ; enddo + endif endif endif @@ -1443,7 +1457,11 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (visc_limit_h_flag(i,j,k) > 0) then Kh_BS(i,j) = 0. else - Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + if (use_kh_struct) then + Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + else + Kh_BS(i,j) = MEKE%Ku(i,j) + endif endif enddo ; enddo @@ -1618,10 +1636,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (might be negative) - Kh(I,J) = Kh(I,J) + 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & - (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & - ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & - (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) * meke_res_fn + if (use_kh_struct) then + Kh(I,J) = Kh(I,J) + 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) * meke_res_fn + else + Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + & + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + & + MEKE%Ku(i,j+1)) ) * meke_res_fn + endif endif if (CS%anisotropic) & @@ -1789,10 +1814,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (visc_limit_q_flag(I,J,k) > 0) then Kh_BS(I,J) = 0. else - Kh_BS(I,J) = 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & - (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & - ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & - (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) + if (use_kh_struct) then + Kh_BS(I,J) = 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) + else + Kh_BS(I,J) = 0.25*( (MEKE%Ku(i,j) + & + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + & + MEKE%Ku(i,j+1)) ) + endif endif enddo ; enddo diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e541cecdcb..8f388dc263 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -18,6 +18,8 @@ module MOM_lateral_mixing_coeffs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init use MOM_open_boundary, only : ocean_OBC_type +use MOM_MEKE_types, only : MEKE_type + implicit none ; private @@ -50,6 +52,14 @@ module MOM_lateral_mixing_coeffs !! as the vertical structure of thickness diffusivity. logical :: kdgl90_use_ebt_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of diffusivity in the GL90 scheme. + logical :: kdgl90_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of diffusivity in the GL90 scheme. + logical :: khth_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of thickness diffusivity. + logical :: khtr_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. + logical :: khtr_use_sqg_struct !< If true, uses the surface quasigeostrophic structure + !! as the vertical structure of tracer diffusivity. logical :: calculate_cg1 !< If true, calls wave_speed() to calculate the first !! baroclinic wave speed and populate CS%cg1. !! This parameter is set depending on other parameters. @@ -112,9 +122,15 @@ module MOM_lateral_mixing_coeffs real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [Z L-1 ~> nondim] real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [Z L-1 ~> nondim] - real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] + real, allocatable :: ebt_struct(:,:,:) !< EBT vertical structure to scale diffusivities with [nondim] + real, allocatable :: sqg_struct(:,:,:) !< SQG vertical structure to scale diffusivities with [nondim] real, allocatable :: BS_struct(:,:,:) !< Vertical structure function used in backscatter [nondim] + real, allocatable :: khth_struct(:,:,:) !< Vertical structure function used in thickness diffusivity [nondim] + real, allocatable :: khtr_struct(:,:,:) !< Vertical structure function used in tracer diffusivity [nondim] + real, allocatable :: kdgl90_struct(:,:,:) !< Vertical structure function used in GL90 diffusivity [nondim] real :: BS_EBT_power !< Power to raise EBT vertical structure to. Default 0.0. + real :: sqg_expo !< Exponent for SQG vertical structure [nondim]. Default 1.0 + logical :: BS_use_sqg_struct !< If true, use sqg_stuct for backscatter vertical structure. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & @@ -163,6 +179,8 @@ module MOM_lateral_mixing_coeffs integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 + integer :: id_sqg_struct=-1, id_BS_struct=-1, id_khth_struct=-1, id_khtr_struct=-1 + integer :: id_kdgl90_struct=-1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. !>@} @@ -173,7 +191,7 @@ module MOM_lateral_mixing_coeffs end type VarMix_CS public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function -public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function +public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function, calc_sqg_struct contains @@ -214,13 +232,15 @@ subroutine calc_depth_function(G, CS) end subroutine calc_depth_function !> Calculates and stores the non-dimensional resolution functions -subroutine calc_resoln_function(h, tv, G, GV, US, CS) +subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + real, intent(in) :: dt !< Time increment [T ~> s] ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some @@ -241,7 +261,8 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%calculate_cg1) then if (.not. allocated(CS%cg1)) call MOM_error(FATAL, & "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") - if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0.) then + if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%khtr_use_ebt_struct .or. CS%BS_EBT_power>0.) then if (.not. allocated(CS%ebt_struct)) call MOM_error(FATAL, & "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then @@ -261,10 +282,50 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif + if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & + .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then + call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) + call pass_var(CS%sqg_struct, G%Domain) + endif + if (CS%BS_EBT_power>0.) then do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%BS_struct(i,j,k) = CS%ebt_struct(i,j,k)**CS%BS_EBT_power enddo ; enddo ; enddo + elseif (CS%BS_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khth_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khth_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khtr_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khtr_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%kdgl90_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%kdgl90_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo endif ! Calculate and store the ratio between deformation radius and grid-spacing @@ -460,6 +521,10 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (query_averaging_enabled(CS%diag)) then if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) + if (CS%id_BS_struct > 0) call post_data(CS%id_BS_struct, CS%BS_struct, CS%diag) + if (CS%id_khth_struct > 0) call post_data(CS%id_khth_struct, CS%khth_struct, CS%diag) + if (CS%id_khtr_struct > 0) call post_data(CS%id_khtr_struct, CS%khtr_struct, CS%diag) + if (CS%id_kdgl90_struct > 0) call post_data(CS%id_kdgl90_struct, CS%kdgl90_struct, CS%diag) endif if (CS%debug) then @@ -470,6 +535,80 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) end subroutine calc_resoln_function +!> Calculates and stores functions of SQG mode +subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv ! s] + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + + ! Local variables + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + e ! The interface heights relative to mean sea level [Z ~> m]. + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1] + real :: N2 ! Positive buoyancy frequency square or zero [L2 Z-2 T-2 ~> s-2] + real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [m] + real :: f_subround ! The minimal resolved value of Coriolis parameter to prevent division by zero [T-1 ~> s-1] + real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [m] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + f_subround = 1.0e-40 * US%s_to_T + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& + "Module must be initialized before it is used.") + + call find_eta(h, tv, G, GV, US, e, halo_size=2) + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v,dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1) + + if (CS%sqg_expo<=0.) then + CS%sqg_struct(:,:,:) = 1. + else + do j=js,je ; do i=is,ie + CS%sqg_struct(i,j,1) = 1.0 + enddo ; enddo + if (allocated(MEKE%Le)) then + do j=js,je ; do i=is,ie + Le(i,j) = MEKE%Le(i,j) + f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) + enddo ; enddo + else + do j=js,je ; do i=is,ie + Le(i,j) = sqrt(G%areaT(i,j)) + f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) + enddo ; enddo + endif + do k=2,nz ; do j=js,je ; do i=is,ie + N2 = max(0.25 * ((N2_u(I-1,j,k) + N2_u(I,j,k)) + (N2_v(i,J-1,k) + N2_v(i,J,k))), 0.0) + dzc = 0.25 * ((dzu(I-1,j,k) + dzu(I,j,k)) + (dzv(i,J-1,k) + dzv(i,J,k))) + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (dzc * sqrt(N2)/(f(i,j) * Le(i,j)))) + enddo ; enddo ; enddo + endif + + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_sqg_struct > 0) call post_data(CS%id_sqg_struct, CS%sqg_struct, CS%diag) + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif + +end subroutine calc_sqg_struct + !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) @@ -1260,14 +1399,37 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "BACKSCAT_EBT_POWER", CS%BS_EBT_power, & "Power to raise EBT vertical structure to when backscatter "// & "has vertical structure.", units="nondim", default=0.0) + call get_param(param_file, mdl, "BS_USE_SQG_STRUCT", CS%BS_use_sqg_struct, & + "If true, the SQG vertical structure is used for backscatter "//& + "on the condition that BS_EBT_power=0", & + default=.false.) + call get_param(param_file, mdl, "SQG_EXPO", CS%sqg_expo, & + "Nondimensional exponent coeffecient of the SQG mode "// & + "that is used for the vertical struture of diffusivities.", units="nondim", default=1.0) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& default=.false.) + call get_param(param_file, mdl, "KHTH_USE_SQG_STRUCT", CS%khth_use_sqg_struct, & + "If true, uses the surface quasigeostrophic structure "//& + "as the vertical structure of thickness diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%khtr_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of tracer diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KHTR_USE_SQG_STRUCT", CS%khtr_use_sqg_struct, & + "If true, uses the surface quasigeostrophic structure "//& + "as the vertical structure of tracer diffusivity.",& + default=.false.) call get_param(param_file, mdl, "KD_GL90_USE_EBT_STRUCT", CS%kdgl90_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of diffusivity in the GL90 scheme.",& default=.false.) + call get_param(param_file, mdl, "KD_GL90_USE_SQG_STRUCT", CS%kdgl90_use_sqg_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of diffusivity in the GL90 scheme.",& + default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", default=0.0) @@ -1311,7 +1473,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & - .or. CS%BS_EBT_power>0.) then + .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& @@ -1320,8 +1482,47 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif - allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) - CS%BS_struct(:,:,:) = 1.0 + + + if (CS%BS_EBT_power>0. .and. CS%BS_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: BS_EBT_POWER>0. & + & and BS_USE_SQG=True cannot be set together") + endif + + if (CS%khth_use_ebt_struct .and. CS%khth_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTH_USE_EBT_STRUCT & + & and KHTH_USE_SQG_STRUCT can be true") + endif + + if (CS%khtr_use_ebt_struct .and. CS%khtr_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTR_USE_EBT_STRUCT & + & and KHTR_USE_SQG_STRUCT can be true") + endif + + if (CS%kdgl90_use_ebt_struct .and. CS%kdgl90_use_sqg_struct) then + call MOM_error(FATAL, & + "calc_resoln_function: Only one of KD_GL90_USE_EBT_STRUCT & + & and KD_GL90_USE_SQG_STRUCT can be true") + endif + + if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then + allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) then + allocate(CS%khth_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) then + allocate(CS%khtr_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) then + allocate(CS%kdgl90_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif if (CS%use_stored_slopes) then if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then @@ -1335,7 +1536,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif endif - if (CS%use_stored_slopes) then + if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then ! CS%calculate_Eady_growth_rate=.true. in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,GV%ke+1), source=0.0) @@ -1418,7 +1619,31 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'm2', conversion=US%L_to_m**2) endif - if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then + CS%id_sqg_struct = register_diag_field('ocean_model', 'sqg_struct', diag%axesTl, Time, & + 'Vertical structure of SQG mode', 'nondim') + if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & + .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then + allocate(CS%sqg_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then + CS%id_BS_struct = register_diag_field('ocean_model', 'BS_struct', diag%axesTl, Time, & + 'Vertical structure of backscatter', 'nondim') + endif + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) then + CS%id_khth_struct = register_diag_field('ocean_model', 'khth_struct', diag%axesTl, Time, & + 'Vertical structure of thickness diffusivity', 'nondim') + endif + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) then + CS%id_khtr_struct = register_diag_field('ocean_model', 'khtr_struct', diag%axesTl, Time, & + 'Vertical structure of tracer diffusivity', 'nondim') + endif + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) then + CS%id_kdgl90_struct = register_diag_field('ocean_model', 'kdgl90_struct', diag%axesTl, Time, & + 'Vertical structure of GL90 diffusivity', 'nondim') + endif + + if ((CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) ) then CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) @@ -1670,11 +1895,15 @@ end subroutine VarMix_init subroutine VarMix_end(CS) type(VarMix_CS), intent(inout) :: CS - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0.) & - deallocate(CS%ebt_struct) + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) deallocate(CS%ebt_struct) + if (allocated(CS%sqg_struct)) deallocate(CS%sqg_struct) if (allocated(CS%BS_struct)) deallocate(CS%BS_struct) + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) deallocate(CS%khth_struct) + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) deallocate(CS%khtr_struct) + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) deallocate(CS%kdgl90_struct) - if (CS%use_stored_slopes) then + if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then deallocate(CS%slope_x) deallocate(CS%slope_y) endif diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b2f022ad18..daea75e73d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -179,7 +179,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp ! to layer centers [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at v-points averaged ! to layer centers [L2 T-1 ~> m2 s-1] - logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck + logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_vert_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz @@ -198,7 +198,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif use_VarMix = .false. ; Resoln_scaled = .false. ; use_stored_slopes = .false. - khth_use_ebt_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. + khth_use_vert_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. Depth_scaled = .false. if (VarMix%use_variable_mixing) then @@ -206,7 +206,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp Resoln_scaled = VarMix%Resoln_scaled_KhTh Depth_scaled = VarMix%Depth_scaled_KhTh use_stored_slopes = VarMix%use_stored_slopes - khth_use_ebt_struct = VarMix%khth_use_ebt_struct + khth_use_vert_struct = allocated(VarMix%khth_struct) use_Visbeck = VarMix%use_Visbeck use_QG_Leith = VarMix%use_QG_Leith_GM if (allocated(VarMix%cg1)) cg1 => VarMix%cg1 @@ -298,10 +298,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) enddo ; enddo - if (khth_use_ebt_struct) then + if (khth_use_vert_struct) then !$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) ) + KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%khth_struct(i,j,k-1) + VarMix%khth_struct(i+1,j,k-1) ) enddo ; enddo ; enddo else !$OMP do @@ -394,10 +394,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo endif - if (khth_use_ebt_struct) then + if (khth_use_vert_struct) then !$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) ) + KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%khth_struct(i,j,k-1) + VarMix%khth_struct(i,j+1,k-1) ) enddo ; enddo ; enddo else !$OMP do diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e241d191b2..f119ccb040 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -616,7 +616,7 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! otherwise they are v-points. ! local variables - logical :: kdgl90_use_ebt_struct + logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient integer :: i, k, is, ie, nz, Isq, Ieq real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error @@ -629,9 +629,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va nz = GV%ke h_neglect = GV%dZ_subroundoff - kdgl90_use_ebt_struct = .false. + kdgl90_use_vert_struct = .false. if (VarMix%use_variable_mixing) then - kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct + kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct) endif if (work_on_u) then @@ -647,8 +647,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va else a_cpl_gl90(I,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - if (kdgl90_use_ebt_struct) then - a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + if (kdgl90_use_vert_struct) then + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * & + ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1) ) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, @@ -671,8 +672,9 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va else a_cpl_gl90(i,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - if (kdgl90_use_ebt_struct) then - a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + if (kdgl90_use_vert_struct) then + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * & + ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1) ) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 051ac446db..1aaf7409d2 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -57,8 +57,8 @@ module MOM_neutral_diffusion logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a !! transition zone defined using boundary layer depths. Only available when !! interior_only=true. - logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure - !! as the vertical structure of tracer diffusivity. + logical :: KhTh_use_vert_struct !< If true, uses vertical structure + !! for tracer diffusivity. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -67,7 +67,7 @@ module MOM_neutral_diffusion !! at cell interfaces [nondim] real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, !! at cell interfaces [nondim] - ! Array used when KhTh_use_ebt_struct is true + ! Array used when KhTh_use_vert_struct is true real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] @@ -153,6 +153,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, logical :: boundary_extrap ! Indicate whether high-order boundary !! extrapolation should be used within boundary cells. logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + logical :: KhTh_use_ebt_struct, KhTh_use_sqg_struct if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -197,10 +198,14 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "a transition zone defined using boundary layer depths. "//& "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) endif - call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", KhTh_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of the tracer diffusivity.",& default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "KHTR_USE_SQG_STRUCT", KhTh_use_sqg_struct, & + "If true, uses the surface geostrophic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& @@ -296,7 +301,8 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, endif endif - if (CS%KhTh_use_ebt_struct) & + CS%KhTh_use_vert_struct = KhTh_use_ebt_struct .or. KhTh_use_sqg_struct + if (CS%KhTh_use_vert_struct) & allocate(CS%Coef_h(G%isd:G%ied,G%jsd:G%jed,SZK_(GV)+1), source=0.) ! Store a rescaling factor for use in diagnostic messages. @@ -624,11 +630,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer in units that vary between a ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), - ! depending on the setting of CS%KhTh_use_ebt_struct. + ! depending on the setting of CS%KhTh_use_vert_struct. real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer in units that vary between a ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), - ! depending on the setting of CS%KhTh_use_ebt_struct. + ! depending on the setting of CS%KhTh_use_vert_struct. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency ! tendency array for diagnostics ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] ! For temperature these units are @@ -673,7 +679,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif endif - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then ! Compute Coef at h points CS%Coef_h(:,:,:) = 0. do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -706,7 +712,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) vFlx(:,:,:) = 0. ! x-flux - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then if (CS%tapering) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then @@ -770,7 +776,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif ! y-flux - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then if (CS%tapering) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec if (G%mask2dCv(i,J)>0.) then @@ -837,7 +843,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Update the tracer concentration from divergence of neutral diffusive flux components, noting ! that uFlx and vFlx use an unexpected sign convention. - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do j = G%jsc,G%jec ; do i = G%isc,G%iec if (G%mask2dT(i,j)>0.) then if (CS%ndiff_answer_date <= 20240330) then @@ -940,7 +946,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfx_2d > 0) then - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then @@ -969,7 +975,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfy_2d > 0) then - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTh_use_vert_struct) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 855c6bef30..3511b88f39 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -52,7 +52,7 @@ module MOM_tracer_hor_diff real :: max_diff_CFL !< If positive, locally limit the along-isopycnal !! tracer diffusivity to keep the diffusive CFL !! locally at or below this value [nondim]. - logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + logical :: KhTr_use_vert_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of tracer diffusivity. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. @@ -218,6 +218,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ use_VarMix = VarMix%use_variable_mixing Resoln_scaled = VarMix%Resoln_scaled_KhTr use_Eady = CS%KhTr_Slope_Cff > 0. + CS%KhTr_use_vert_struct = allocated(VarMix%khtr_struct) endif call cpu_clock_begin(id_clock_pass) @@ -422,18 +423,18 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo do k=2,nz+1 do j=js,je do I=is-1,ie - Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -478,18 +479,18 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo do k=2,nz+1 do j=js,je do I=is-1,ie - Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -605,11 +606,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do j=js,je ; do I=is-1,ie Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do j=js,je do I=is-1,ie - Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) enddo enddo enddo @@ -621,11 +622,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do J=js-1,je ; do i=is,ie Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie - Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) enddo enddo enddo @@ -647,9 +648,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_vert_struct) then do K=2,nz+1 - Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%khtr_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) enddo endif @@ -1630,10 +1631,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR", CS%KhTr, & "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) - call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & - "If true, uses the equivalent barotropic structure "//& - "as the vertical structure of the tracer diffusivity.",& - default=.false.) +! call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & +! "If true, uses the equivalent barotropic structure "//& +! "as the vertical structure of the tracer diffusivity.",& +! default=.false.) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & "The scaling coefficient for along-isopycnal tracer "//& "diffusivity using a shear-based (Visbeck-like) "//& From 2b72682f10823d7264a92caedd6d3c770992bb37 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 25 Nov 2024 16:15:50 -0500 Subject: [PATCH 122/128] *+HOR_VISC_ANSWER_DATE logic fix When HOR_VISC_ANSWER_DATE was introduced to replace HOR_VISC_2018_ANSWERS on August 4, 2022 as a part of github.com/NOAA-GFDL/MOM6/pull/179, the logic was incorrectly specified, using the older form with the newer answer date and vice versa, because `(CS%answer_date > 20190101)` was used instead of `(CS%answer_date < 20190101)`. (Curiously, using exactly 20190101 actually gives the intended result.) This commit modifies this logic so that the older (mildly dimensionally inconsistent) version is now being used for answer dates between 20190102 and 20241201, but a very late answer date uses the corrected form. The offending block of code is only used when USE_MEKE is true and the Rossby number scaling of the biharmonic energy source is enabled by setting MEKE_BACKSCAT_RO_C > 0, which does not appear to be very common. To avoid logging the description of this ugly new logic in MOM_parameter_doc files where it does not impact the solutions, new logic was added to limit the logging of HOR_VISC_ANSWER_DATE. Also, as there are no known non-Boussinesq cases with this combination of MEKE parameters, the minimum value of HOR_VISC_ANSWER_DATE was changed to 20241201 when the model is in non-Boussinesq mode. Because this bug went undetected when it was first introduced, it probably is not widely used, and it might make sense to obsolete HOR_VISC_ANSWER_DATE and eliminate the older, inconsistent block of code. This commit could change answers for answer dates that are above 20241201 with the MEKE Rossby number scaling enabled via MEKE_BACKSCAT_RO_C > 0. --- .../lateral/MOM_hor_visc.F90 | 25 +++++++++++++------ 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index fa5bb40577..92794c54e7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2141,7 +2141,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, Shear_mag_bc = sqrt(sh_xx(i,j) * sh_xx(i,j) + & 0.25*(((sh_xy(I-1,J-1)*sh_xy(I-1,J-1)) + (sh_xy(I,J)*sh_xy(I,J))) + & ((sh_xy(I-1,J)*sh_xy(I-1,J)) + (sh_xy(I,J-1)*sh_xy(I,J-1))))) - if (CS%answer_date > 20190101) then + if ((CS%answer_date > 20190101) .and. (CS%answer_date < 20241201)) then FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n ! Note the hard-coded dimensional constant in the following line that can not ! be rescaled for dimensional consistency. @@ -2332,6 +2332,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: use_MEKE ! If true, the MEKE parameterization is in use. + real :: backscatter_Ro_c ! Coefficient in Rossby number function for backscatter [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags character(len=200) :: inputdir, filename ! Input file names and paths character(len=80) :: Kh_var ! Input variable names @@ -2363,13 +2364,23 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + + ! Determine whether HOR_VISC_ANSWER_DATE is used, and avoid logging it if it is not used. + call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & + default=.false., do_not_log=.true.) + backscatter_Ro_c = 0.0 + if (use_MEKE) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", backscatter_Ro_c, & + "The coefficient in the Rossby number function for scaling the biharmonic "//& + "frictional energy source. Setting to non-zero enables the Rossby number function.", & + units="nondim", default=0.0, do_not_log=.true.) + call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& - "viscosity calculations. Values below 20190101 recover the answers from the "//& - "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions.", & - default=default_answer_date, do_not_log=.not.GV%Boussinesq) - if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + "viscosity calculations. Values between 20190102 and 20241201 recover the "//& + "answers from the end of 2018, while higher values use updated and more robust "//& + "forms of the same expressions.", & + default=default_answer_date, do_not_log=(.not.GV%Boussinesq).or.(backscatter_Ro_c==0.0)) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20241201) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & @@ -2425,8 +2436,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "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, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false., & From 59ad6b245f33faa40b7c9d0d96c5a7055cdda814 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 15 Dec 2024 16:42:40 -0500 Subject: [PATCH 123/128] MEKE: Split src and src_GM compute loops The MEKE GM computation of `src` and `src_GM`, a diagnostic array, were placed in a single loop. The similar RHS of each expression made it unfavorable to use FMAs on the `src` update. Older production runs depending on this FMA were seeing answer changes. This patch restores the FMA loop update of `src` by separating `src` and `src_GM` into separate loops. --- src/parameterizations/lateral/MOM_MEKE.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 4bac09b7cc..886ce720d5 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -448,6 +448,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + enddo ; enddo + + do j=js,je ; do i=is,ie src_GM(i,j) = -CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo endif From 4a3b4b2575e32c976d34be14cd77d5addf9624c1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 16 Dec 2024 00:48:22 -0500 Subject: [PATCH 124/128] MEKE: Conditionally compute biharmonic FrCoeff This patch makes several adjustments to MOM_MEKE.F90 and MOM_hor_visc.F90 to ensure that the Laplacian and biharmonic friction coefficients are computed separately, and only if their respective terms are enabled. This resolves some subtle bugs where the default biharmonic value of -1 was applied to the Laplacian case, even when the biharmonic MEKE friction was disabled. --- src/parameterizations/lateral/MOM_MEKE.F90 | 57 +++++++++++++++---- .../lateral/MOM_hor_visc.F90 | 26 ++++++--- 2 files changed, 64 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 886ce720d5..bf02248876 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -227,6 +227,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] + real :: bh_coeff ! Biharmonic part of efficiency conversion in total MEKE [nondim] real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] @@ -412,24 +413,53 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = CS%MEKE_BGsrc - src_adv(i,j) = 0. - src_mom_K4(i,j) = 0. - src_btm_drag(i,j) = 0. - src_GM(i,j) = 0. - src_mom_lp(i,j) = 0. - src_mom_bh(i,j) = 0. enddo ; enddo + ! Initialize diagnostics + ! TODO: Remove these after the damping is only computed if the diagnostic + ! is registered. + if (CS%id_src_adv > 0) src_adv(is:ie, js:je) = 0. + if (CS%id_src_GM > 0) src_GM(is:ie, js:je) = 0. + if (CS%id_src_mom_lp > 0) src_mom_lp(is:ie, js:je) = 0. + if (CS%id_src_mom_bh > 0) src_mom_bh(is:ie, js:je) = 0. + if (CS%id_src_mom_K4 > 0) src_mom_K4(is:ie, js:je) = 0. + if (CS%id_src_btm_drag > 0) src_btm_drag(is:ie, js:je) = 0. + if (allocated(MEKE%mom_src)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) & - - (CS%MEKE_bhFrCoeff-CS%MEKE_FrCoeff)*I_mass(i,j)*MEKE%mom_src_bh(i,j) - src_mom_lp(i,j) = - CS%MEKE_FrCoeff*I_mass(i,j)*(MEKE%mom_src(i,j)-MEKE%mom_src_bh(i,j)) - src_mom_bh(i,j) = - CS%MEKE_bhFrCoeff*I_mass(i,j)*MEKE%mom_src_bh(i,j) + src(i,j) = src(i,j) - CS%MEKE_FrCoeff * I_mass(i,j) * MEKE%mom_src(i,j) enddo ; enddo endif + if (allocated(MEKE%mom_src_bh)) then + if (CS%MEKE_bhFrCoeff > 0. .and. CS%MEKE_FrCoeff > 0.) then + bh_coeff = CS%MEKE_bhFrCoeff - CS%MEKE_FrCoeff + else + bh_coeff = CS%MEKE_bhFrCoeff + endif + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - bh_coeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) + enddo ; enddo + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = -CS%MEKE_FrCoeff * I_mass(i,j) & + * (MEKE%mom_src(i,j) - MEKE%mom_src_bh(i,j)) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = -CS%MEKE_bhFrCoeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) + enddo ; enddo + endif + endif + if (allocated(MEKE%GME_snk)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -489,6 +519,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif + ! TODO: All of these diagnostics needs to be pulled out of the MEKE damping + ! loop and handled separately, and only if they are registered. + ! First stage of Strang splitting !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -1890,10 +1923,10 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, 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_bhFrCoeff>=0. .or. MEKE_GMECoeff>=0.) then + if (MEKE_FrCoeff>=0. .or. MEKE_bhFrCoeff>=0. .or. MEKE_GMECoeff>=0.) & allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) + if (MEKE_bhFrCoeff >= 0.) & allocate(MEKE%mom_src_bh(isd:ied,jsd:jed), source=0.0) - endif if (MEKE_FrCoeff<0.) MEKE_FrCoeff = 0. if (MEKE_bhFrCoeff<0.) MEKE_bhFrCoeff = 0. if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 92794c54e7..c2496e0d3a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2126,8 +2126,14 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (k==1) then do j=js,je ; do i=is,ie MEKE%mom_src(i,j) = 0. - MEKE%mom_src_bh(i,j) = 0. enddo ; enddo + + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = 0. + enddo ; enddo + endif + if (allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie MEKE%GME_snk(i,j) = 0. @@ -2160,15 +2166,21 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (FrictWork(i,j,k) - RoScl*FrictWork_bh(i,j,k)) - MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + & - (FrictWork_bh(i,j,k) - RoScl*FrictWork_bh(i,j,k)) + + if (allocated(MEKE%mom_src_bh)) & + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) & + + (FrictWork_bh(i,j,k) - RoScl * FrictWork_bh(i,j,k)) enddo ; enddo else + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) + enddo ; enddo - do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) - MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k) - enddo ; enddo + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + endif endif ! MEKE%backscatter_Ro_c if (CS%use_GME .and. allocated(MEKE%GME_snk)) then From 0d2d668e3f0cb5f4f2f9183bdfae679e3f93a6c7 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 17 Dec 2024 16:00:31 -0500 Subject: [PATCH 125/128] MEKE: Move flag test outside of FrictWork loop The if-test inside of the FrictWork loops are likely to impede performance. Even if the total work is reduced, they are likely to interrupt pipelines. When EY24_EBT_BS is disabled, they will clearly reduce performance. This patch moves those tests outside of the if-block and applies them separately. (Calculation would be slightly improved if the meaning of the flag were reversed, but I don't want to make additional changes.) --- .../lateral/MOM_hor_visc.F90 | 143 +++++++++--------- 1 file changed, 70 insertions(+), 73 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c2496e0d3a..e4ea7f7ff9 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -480,12 +480,14 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 - visc_limit_h(:,:,:) = 0. - visc_limit_q(:,:,:) = 0. - visc_limit_h_flag(:,:,:) = 0. - visc_limit_q_flag(:,:,:) = 0. - visc_limit_h_frac(:,:,:) = 0. - visc_limit_q_frac(:,:,:) = 0. + if (CS%EY24_EBT_BS) then + visc_limit_h(:,:,:) = 0. + visc_limit_q(:,:,:) = 0. + visc_limit_h_flag(:,:,:) = 0. + visc_limit_q_flag(:,:,:) = 0. + visc_limit_h_frac(:,:,:) = 0. + visc_limit_q_frac(:,:,:) = 0. + endif m_leithy(:,:) = 0.0 ! Initialize @@ -1944,33 +1946,27 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (find_FrictWork) then if (CS%FrictWork_bug) then + ! 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 do j=js,je ; do i=is,ie - ! 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 - if (visc_limit_h_flag(i,j,k) > 0) then - FrictWork(i,j,k) = 0 - else - 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)))) ) ) ) - endif + 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)))) ) ) ) enddo ; enddo - else ; do j=js,je ; do i=is,ie - if (visc_limit_h_flag(i,j,k) > 0) then - FrictWork(i,j,k) = 0 - else + else + do j=js,je ; do i=is,ie FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & ((str_xx(i,j)*CS%dy2h(i,j) * ( & (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & @@ -1999,19 +1995,21 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) - endif - enddo ; enddo ; endif + enddo ; enddo + endif + + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork(i,j,k) + enddo ; enddo + endif endif if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then - if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie - ! 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 - if (visc_limit_h_flag(i,j,k) > 0) then - FrictWork_bh(i,j,k) = 0 - else + if (CS%FrictWork_bug) then ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion !cyc + do j=js,je ; do i=is,ie FrictWork_bh(i,j,k) = GV%H_to_RZ * ( & (bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & @@ -2027,12 +2025,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, + 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)) ) ) ) - endif - enddo ; enddo - else ; do j=js,je ; do i=is,ie - if (visc_limit_h_flag(i,j,k) > 0) then - FrictWork_bh(i,j,k) = 0 - else + enddo ; enddo + else + do j=js,je ; do i=is,ie ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) FrictWork_bh(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & ((bhstr_xx(i,j)*CS%dy2h(i,j) * ( & @@ -2061,11 +2056,15 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) - endif - enddo ; enddo ; endif - endif - + enddo ; enddo + endif + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork_bh(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork_bh(i,j,k) + enddo ; enddo + endif + endif if (CS%use_GME) then if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie @@ -2115,7 +2114,6 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) - enddo ; enddo ; endif endif @@ -2188,9 +2186,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) enddo ; enddo endif - endif ! find_FrictWork and associated(mom_src) - enddo ! end of k loop ! Offer fields for diagnostic averaging. @@ -2219,16 +2215,15 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag) - if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag) - if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag) - if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) - if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) - if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) - if (CS%EY24_EBT_BS) then - if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) - if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) + if (CS%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag) + if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag) + if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag) + if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) + if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) + if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) + if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) + if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) endif if (CS%debug) then @@ -3163,18 +3158,20 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') - CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, & - 'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim') - CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, & - 'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim') - CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, & - 'Value of the biharmonic viscosity limiter at h points', 'nondim') - CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, & - 'Value of the biharmonic viscosity limiter at q points', 'nondim') - CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, & - 'Value of the biharmonic viscosity limiter at h points', 'nondim') - CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, & - 'Value of the biharmonic viscosity limiter at q points', 'nondim') + if (CS%EY24_EBT_BS) then + CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim') + CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim') + CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + endif if (CS%id_grid_Re_Ah > 0) & ! Compute the smallest biharmonic viscosity capable of modifying the From 345a6fb2947e9eb4c33871347662ccfb510342bf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 18 Dec 2024 16:16:56 -0500 Subject: [PATCH 126/128] MEKE: Move damping diagnostics outside MEKE loop The damping MEKE loop also included updates to multiple diagnostics, even if they were not registered. This would presumably have a negative impact on performance. This patch moves each diagnostic into a separate loop. It also conditionally precomputes the damping and damp_rate parameters, which are now stored as 2d arrays rather than in-loop scalars. As before, the MEKE calculation is left unchanged in order to preserve bit reproducibility. --- src/parameterizations/lateral/MOM_MEKE.F90 | 235 ++++++++++++++++----- 1 file changed, 179 insertions(+), 56 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index bf02248876..4e874294ed 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -212,8 +212,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] - equilibrium_value ! The equilibrium value of MEKE to be calculated at each - ! time step [L2 T-2 ~> m2 s-2] + equilibrium_value, & ! The equilibrium value of MEKE to be calculated at + ! each time step [L2 T-2 ~> m2 s-2] + damp_rate, & ! The MEKE damping rate [T-1 ~> s-1] + damping ! The net damping of a field after sdt_damp [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. @@ -238,9 +240,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). real :: damp_step ! Size of damping timestep relative to sdt [nondim] - real :: damp_rate ! The MEKE damping rate [T-1 ~> s-1]. - real :: damping ! The net damping of a field after sdt_damp [nondim] logical :: use_drag_rate ! Flag to indicate drag_rate is finite + logical :: any_damping_diags_s1 ! True if any damped diagnostics are enabled in first stage + logical :: any_damping_diags ! True if any damped diagnostics are enabled integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features ! needed for the machine learning inference, with different @@ -416,8 +418,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo ! Initialize diagnostics - ! TODO: Remove these after the damping is only computed if the diagnostic - ! is registered. if (CS%id_src_adv > 0) src_adv(is:ie, js:je) = 0. if (CS%id_src_GM > 0) src_GM(is:ie, js:je) = 0. if (CS%id_src_mom_lp > 0) src_mom_lp(is:ie, js:je) = 0. @@ -425,7 +425,22 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%id_src_mom_K4 > 0) src_mom_K4(is:ie, js:je) = 0. if (CS%id_src_btm_drag > 0) src_btm_drag(is:ie, js:je) = 0. - if (allocated(MEKE%mom_src)) then + ! Identify any damped diagnostics in first stage of Strang splitting + any_damping_diags_s1 = any([ & + CS%id_src_GM > 0, & + CS%id_src_mom_lp > 0, & + CS%id_src_mom_bh > 0, & + CS%id_src_btm_drag > 0 & + ]) + + ! Identify any damped diagnostics + any_damping_diags = any([ & + any_damping_diags_s1, & + CS%id_src_adv > 0, & + CS%id_src_mom_K4 > 0 & + ]) + + if (CS%MEKE_FrCoeff > 0.) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_FrCoeff * I_mass(i,j) * MEKE%mom_src(i,j) @@ -519,36 +534,75 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif - ! TODO: All of these diagnostics needs to be pulled out of the MEKE damping - ! loop and handled separately, and only if they are registered. - ! First stage of Strang splitting + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - damp_rate = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) damp_rate = 0. + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. ! notice that the above line ensures a damping only if MEKE is positive, ! while leaving MEKE unchanged if it is negative + enddo ; enddo - damping = 1. / (1. + sdt_damp * damp_rate) + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the existing + ! bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo - ! NOTE: MEKE%MEKE should use `damping` but we must preserve the existing - ! expression for bit reproducibility - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate) - MEKE_decay(i,j) = damp_rate * G%mask2dT(i,j) + if (any_damping_diags_s1) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo - src_GM(i,j) = src_GM(i,j) * damping - src_mom_lp(i,j) = src_mom_lp(i,j) * damping - src_mom_bh(i,j) = src_mom_bh(i,j) * damping + if (CS%id_decay > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif - src_btm_drag(i,j) = - MEKE_current(i,j) * ( & - damp_step * (damp_rate * damping) & - ) + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif - ! Store the effective damping rate if sdt is split - if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) & - damp_rate_s1(i,j) = damp_rate * damping - enddo ; enddo + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * ( & + damp_step * (damp_rate(i,j) * damping(i,j)) & + ) + enddo ; enddo + + ! Store the effective damping rate if sdt is split + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate_s1(i,j) = damp_rate(i,j) * damping(i,j) + enddo ; enddo + endif + endif + endif if (CS%kh_flux_enabled .or. CS%MEKE_K4 >= 0.0) then ! Update MEKE in the halos for lateral or bi-harmonic diffusion @@ -687,10 +741,16 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) - src_adv(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & - ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & - (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + enddo ; enddo + endif endif ! MEKE_KH>0 ! Add on bi-harmonic tendency @@ -711,30 +771,80 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - damp_rate = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) damp_rate = 0. + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. ! notice that the above line ensures a damping only if MEKE is positive, ! while leaving MEKE unchanged if it is negative + enddo ; enddo - damping = 1. / (1. + sdt_damp * damp_rate) + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the + ! existing bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo - ! NOTE: As above, MEKE%MEKE should use `damping` but we must preserve - ! the existing expression for bit reproducibility. - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*damp_rate) - MEKE_decay(i,j) = damp_rate*G%mask2dT(i,j) + if (any_damping_diags) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo - src_GM(i,j) = src_GM(i,j) * damping - src_mom_lp(i,j) = src_mom_lp(i,j) * damping - src_mom_bh(i,j) = src_mom_bh(i,j) * damping - src_adv(i,j) = src_adv(i,j) * damping - src_mom_K4(i,j) = src_mom_K4(i,j) * damping + if (CS%id_decay > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif - src_btm_drag(i,j) = -MEKE_current(i,j) * ( & - damp_step * damping * (damp_rate + damp_rate_s1(i,j)) & - ) - enddo ; enddo + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = src_adv(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_K4 > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_K4(i,j) = src_mom_K4(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * (damp_step & + * ((damp_rate(i,j) + damp_rate_s1(i,j)) * damping(i,j)) & + ) + enddo ; enddo + endif + endif endif ! MEKE_KH>=0 if (CS%debug) then @@ -1522,20 +1632,33 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (.not. allocated(MEKE%MEKE)) CS%id_Ut = -1 CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - !add diagnostics for the terms in the MEKE budget + CS%id_src_adv = register_diag_field('ocean_model', 'MEKE_src_adv', diag%axesT1, Time, & 'MEKE energy source from the horizontal advection of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_src_mom_K4 = register_diag_field('ocean_model', 'MEKE_src_mom_K4', diag%axesT1, Time, & - 'MEKE energy source from the biharmonic of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_src_btm_drag = register_diag_field('ocean_model', 'MEKE_src_btm_drag', diag%axesT1, Time, & 'MEKE energy source from the bottom drag acting on MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_src_GM = register_diag_field('ocean_model', 'MEKE_src_GM', diag%axesT1, Time, & - 'MEKE energy source from the thickness mixing (GM scheme)', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_src_mom_lp = register_diag_field('ocean_model', 'MEKE_src_mom_lp', diag%axesT1, Time, & - 'MEKE energy source from the Laplacian of resolved flows', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_src_mom_bh = register_diag_field('ocean_model', 'MEKE_src_mom_bh', diag%axesT1, Time, & - 'MEKE energy source from the biharmonic of resolved flows', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) - !end + + if (CS%MEKE_K4 >= 0.) & + CS%id_src_mom_K4 = register_diag_field('ocean_model', 'MEKE_src_mom_K4', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of MEKE', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_GMcoeff >= 0.) & + CS%id_src_GM = register_diag_field('ocean_model', 'MEKE_src_GM', & + diag%axesT1, Time, 'MEKE energy source from the thickness mixing (GM scheme)', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_FrCoeff >= 0.) & + CS%id_src_mom_lp = register_diag_field('ocean_model', 'MEKE_src_mom_lp', & + diag%axesT1, Time, 'MEKE energy source from the Laplacian of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_bhFrCoeff >= 0.) & + CS%id_src_mom_bh = register_diag_field('ocean_model', 'MEKE_src_mom_bh', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & From 910aa38e6e76d587c25d2d5cda0c0f9ab0cac6c9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 19 Dec 2024 11:17:22 -0500 Subject: [PATCH 127/128] Diffusivity: Revert int_tide_CS to pointer The redefining of int_tide_CS control struct in set_diffusivity_init caused errors in debug-mode for Intel compilers. The issue appears to be an internal function that expects a pointer rather than the type. This patch reverts this back to a pointer. We can revisit this if there is a need to reduce reliance on pointers. --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index d15a364267..fc6d8380c5 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2201,7 +2201,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version From c346c73d002a7c64057ed123e53f58281b308eaa Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 2 Jan 2025 15:59:56 -0500 Subject: [PATCH 128/128] FMA rotation symmetric form of legacy FrictWork_bh This patch updates the expression for FrictWork_bh (biharmonic frictional work) when the FrictWork_bug flag is enabled. The new form is symmetric to rotations when FMA instructions are enabled. --- .../lateral/MOM_hor_visc.F90 | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e4ea7f7ff9..a11b8a232e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2011,20 +2011,20 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! This is the old formulation that includes energy diffusion !cyc do j=js,je ; do i=is,ie FrictWork_bh(i,j,k) = GV%H_to_RZ * ( & - (bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - - bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - + 0.25*((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)) & - + 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)) ) & - + (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)) & - + 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)) ) ) ) + ((bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (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)))) & + + (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)))) ) & + + ( (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)))) & + + (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 else do j=js,je ; do i=is,ie