MOM_ice_shelf_dynamics.F90

1! This file is part of MOM6, the Modular Ocean Model version 6.
2! See the LICENSE file for licensing information.
3! SPDX-License-Identifier: Apache-2.0
4
5!> Implements a crude placeholder for a later implementation of full
6!! ice shelf dynamics.
8
9use mom_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
10use mom_cpu_clock, only : clock_component, clock_routine
11use mom_is_diag_mediator, only : post_data=>post_is_data
12use mom_is_diag_mediator, only : register_diag_field=>register_mom_is_diag_field, safe_alloc_ptr
13!use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid
15use mom_domains, only : mom_domains_init, clone_mom_domain
16use mom_domains, only : pass_var, pass_vector, to_all, cgrid_ne, bgrid_ne, agrid, corner, center
17use mom_domains, only : create_group_pass, do_group_pass, group_pass_type
18use mom_error_handler, only : mom_error, mom_mesg, fatal, warning, is_root_pe
19use mom_file_parser, only : read_param, get_param, log_param, log_version, param_file_type
21use mom_io, only : file_exists, slasher, mom_read_data
22use mom_io, only : open_ascii_file, close_file, get_filename_appendix
23use mom_io, only : append_file, writeonly_file
24use mom_restart, only : register_restart_field, mom_restart_cs
25use mom_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>)
26use mom_time_manager, only : operator(+), operator(-), operator(*), operator(/)
27use mom_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<)
29use mom_checksums, only : is_nan
30!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary
32use mom_coms, only : reproducing_sum, max_across_pes, min_across_pes
33use mom_checksums, only : hchksum, qchksum
37implicit none ; private
38
39#include <MOM_memory.h>
40
45
46! SSA inner solver flags
47integer, parameter :: inner_cg = 1 !< Conjugate gradient (default)
48integer, parameter :: inner_minres = 2 !< MINRES
49integer, parameter :: inner_cr = 3 !< Conjugate residual
50
51! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional
52! consistency testing. These are noted in comments with units like Z, H, L, and T, along with
53! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units
54! vary with the Boussinesq approximation, the Boussinesq variant is given first.
55
56!> The control structure for the ice shelf dynamics.
57type, public :: ice_shelf_dyn_cs ; private
58 real, pointer, dimension(:,:) :: u_shelf => null() !< the zonal velocity of the ice shelf/sheet
59 !! on q-points (B grid) [L T-1 ~> m s-1]
60 real, pointer, dimension(:,:) :: v_shelf => null() !< the meridional velocity of the ice shelf/sheet
61 !! on q-points (B grid) [L T-1 ~> m s-1]
62 real, pointer, dimension(:,:) :: taudx_shelf => null() !< the zonal driving stress of the ice shelf/sheet
63 !! on q-points (C grid) [R L2 T-2 ~> Pa]
64 real, pointer, dimension(:,:) :: taudy_shelf => null() !< the meridional driving stress of the ice shelf/sheet
65 !! on q-points (C grid) [R L2 T-2 ~> Pa]
66 real, pointer, dimension(:,:) :: sx_shelf => null() !< the zonal surface slope of the ice shelf/sheet
67 !! on q-points (B grid) [nondim]
68 real, pointer, dimension(:,:) :: sy_shelf => null() !< the meridional surface slope of the ice shelf/sheet
69 !! on q-points (B grid) [nondim]
70 real, pointer, dimension(:,:) :: u_face_mask => null() !< mask for velocity boundary conditions on the C-grid
71 !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER,
72 !! not vertices. Will represent boundary conditions on computational boundary
73 !! (or permanent boundary between fast-moving and near-stagnant ice
74 !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition,
75 !! 3=inhomogeneous Dirichlet boundary for u and v, 4=flux boundary: at these
76 !! faces a flux will be specified which will override velocities; a homogeneous
77 !! velocity condition will be specified (this seems to give the solver less
78 !! difficulty) 5=inhomogenous Dirichlet boundary for u only. 6=inhomogenous
79 !! Dirichlet boundary for v only
80 real, pointer, dimension(:,:) :: v_face_mask => null() !< A mask for velocity boundary conditions on the C-grid
81 !! v-face, with valued defined similarly to u_face_mask, but 5 is Dirichlet for v
82 !! and 6 is Dirichlet for u
83 real, pointer, dimension(:,:) :: u_face_mask_bdry => null() !< A duplicate copy of u_face_mask?
84 real, pointer, dimension(:,:) :: v_face_mask_bdry => null() !< A duplicate copy of v_face_mask?
85 real, pointer, dimension(:,:) :: u_flux_bdry_val => null() !< The ice volume flux per unit face length into the cell
86 !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1]
87 real, pointer, dimension(:,:) :: v_flux_bdry_val => null() !< The ice volume flux per unit face length into the cell
88 !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]??
89 ! needed where u_face_mask is equal to 4, similarly for v_face_mask
90 real, pointer, dimension(:,:) :: umask => null() !< u-mask on the actual degrees of freedom (B grid)
91 !! 1=normal node, 3=inhomogeneous boundary node,
92 !! 0 - no flow node (will also get ice-free nodes)
93 real, pointer, dimension(:,:) :: vmask => null() !< v-mask on the actual degrees of freedom (B grid)
94 !! 1=normal node, 3=inhomogeneous boundary node,
95 !! 0 - no flow node (will also get ice-free nodes)
96 real, pointer, dimension(:,:) :: calve_mask => null() !< a mask to prevent the ice shelf front from
97 !! advancing past its initial position (but it may retreat)
98 real, pointer, dimension(:,:) :: t_shelf => null() !< Vertically integrated temperature in the ice shelf/stream,
99 !! on corner-points (B grid) [C ~> degC]
100 real, pointer, dimension(:,:) :: tmask => null() !< A mask on tracer points that is 1 where there is ice.
101 real, pointer, dimension(:,:,:) :: ice_visc => null() !< Area and depth-integrated Glen's law ice viscosity
102 !! (Pa m3 s) in [R L4 Z T-1 ~> kg m2 s-1].
103 !! at either 1 (cell-centered) or 4 quadrature points per cell
104 real, pointer, dimension(:,:,:) :: newton_visc_factor => null() !< Newton tangent stiffness coefficient:
105 !! (1/n_glen - 1)/2 * ice_visc / eps_e2 at each
106 !! viscosity quadrature point [R L4 Z T ~> kg m2 s]
107 real, pointer, dimension(:,:,:) :: newton_str_ux => null() !< Longitudinal x-strain-rate ux at each viscosity
108 !! quadrature point for Newton iterations [T-1 ~> s-1]
109 real, pointer, dimension(:,:,:) :: newton_str_vy => null() !< Longitudinal y-strain-rate vy at each viscosity
110 !! quadrature point for Newton iterations [T-1 ~> s-1]
111 real, pointer, dimension(:,:,:) :: newton_str_sh => null() !< Engineering shear strain-rate uy+vx at each
112 !! viscosity quadrature point for Newton iterations [T-1 ~> s-1]
113 real, pointer, dimension(:,:) :: aglen_visc => null() !< Ice-stiffness parameter in Glen's law ice viscosity,
114 !! often in [Pa-3 s-1] if n_Glen is 3.
115 real, pointer, dimension(:,:) :: u_bdry_val => null() !< The zonal ice velocity at inflowing boundaries
116 !! [L yr-1 ~> m yr-1]
117 real, pointer, dimension(:,:) :: v_bdry_val => null() !< The meridional ice velocity at inflowing boundaries
118 !! [L yr-1 ~> m yr-1]
119 real, pointer, dimension(:,:) :: h_bdry_val => null() !< The ice thickness at inflowing boundaries [Z ~> m].
120 real, pointer, dimension(:,:) :: t_bdry_val => null() !< The ice temperature at inflowing boundaries [C ~> degC].
121
122 real, pointer, dimension(:,:) :: bed_elev => null() !< The bed elevation used for ice dynamics [Z ~> m],
123 !! relative to mean sea-level. This is
124 !! the same as G%bathyT+Z_ref, when below sea-level.
125 !! Sign convention: positive below sea-level, negative above.
126
127 real, pointer, dimension(:,:) :: c_basal_friction => null()!< Coefficient in sliding law tau_b = C u^(n_basal_fric),
128 !! units of [R L Z T-2 (s m-1)^(n_basal_fric) ~> Pa (s m-1)^(n_basal_fric)]
129 real, pointer, dimension(:,:) :: coef_prefactor => null() !< Pre-computed area*C_basal_friction*L_T_to_m_s for
130 !! basal friction quadrature evaluation [R L2 Z T-1 ~> kg s-1].
131 real, pointer, dimension(:,:) :: fb_elem => null() !< Pre-computed element-level Coulomb fB parameter
132 !! [(s m-1)^CF_PostPeak]; 0 for Weertman.
133 !! Updated each outer iteration by calc_shelf_basal_prefactors.
134 real :: alpha_coulomb = 1.0 !< Coulomb prefactor (CF_PostPeak-1)^(CF_PostPeak-1)/CF_PostPeak^CF_PostPeak [nondim]
135 real :: coulomb_pp_n !< CF_PostPeak/n_basal_fric [nondim]
136 real, pointer, dimension(:,:) :: od_rt => null() !< A running total for calculating OD_av [Z ~> m].
137 real, pointer, dimension(:,:) :: ground_frac_rt => null() !< A running total for calculating ground_frac.
138 real, pointer, dimension(:,:) :: od_av => null() !< The time average open ocean depth [Z ~> m].
139 real, pointer, dimension(:,:) :: ground_frac => null() !< Fraction of the time a cell is "exposed", i.e. the column
140 !! thickness is below a threshold and interacting with the rock [nondim]. When this
141 !! is 1, the ice-shelf is grounded
142 real, pointer, dimension(:,:) :: float_cond => null() !< If GL_regularize=true, indicates cells containing
143 !! the grounding line (float_cond=1) or not (float_cond=0)
144 real, pointer, dimension(:,:,:,:) :: phi => null() !< The gradients of bilinear basis elements at Gaussian
145 !! 4 quadrature points surrounding the cell vertices [L-1 ~> m-1].
146 real, pointer, dimension(:,:,:) :: phic => null() !< The gradients of bilinear basis elements at 1 cell-centered
147 !! quadrature point per cell [L-1 ~> m-1].
148 real, pointer, dimension(:,:,:) :: jac => null() !< Jacobian determinant |J_q| = a_q*d_q of the element
149 !! mapping at each of the 4 Gaussian quadrature points [L2 ~> m2].
150 !! Equal to G%areaT only for rectangular elements; differs when
151 !! opposite cell edges have unequal lengths (non-rectangular quads).
152 real, pointer, dimension(:,:,:,:,:,:) :: phisub => null() !< Quadrature structure weights at subgridscale
153 !! locations for finite element calculations [nondim]
154 integer :: od_rt_counter = 0 !< A counter of the number of contributions to OD_rt.
155
156 real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity
157 !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s].
158 ! DNGoldberg thinks this should be done no more often than about once a day
159 ! (maybe longer) because it will depend on ocean values that are averaged over
160 ! this time interval, and solving for the equilibrated flow will begin to lose
161 ! meaning if it is done too frequently.
162 real :: elapsed_velocity_time !< The elapsed time since the ice velocities were last updated [T ~> s].
163
164 real :: g_earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2].
165 real :: density_ice !< A typical density of ice [R ~> kg m-3].
166 real :: cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1].
167
168 logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness
169 logical :: reentrant_x !< If true, the domain is zonally reentrant
170 logical :: reentrant_y !< If true, the domain is meridionally reentrant
171 logical :: alternate_first_direction_is !< If true, alternate whether the x- or y-direction
172 !! updates occur first in directionally split parts of the calculation.
173 integer :: first_direction_is !< An integer that indicates which direction is
174 !! to be updated first in directionally split
175 !! parts of the ice sheet calculation (e.g. advection).
176 real :: first_dir_restart_is = -1.0 !< A real copy of CS%first_direction_IS for use in restart files
177 integer :: visc_qps !< The number of quadrature points per cell (1 or 4) on which to calculate ice viscosity.
178 character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally
179 !! according to Glen's flow law; is constant (for debugging purposes)
180 !! or using observed strain rates and read from a file
181 logical :: shelf_top_slope_bugs !< If true, use directionally inconsistent estimates of the grid
182 !! spacing when calculating the ice shelf surface slope, and underestimate
183 !! slopes near the edge of the ice shelf by a factor of 2.
184 logical :: gl_regularize !< Specifies whether to regularize the floatation condition
185 !! at the grounding line as in Goldberg Holland Schoof 2009
186 integer :: n_sub_regularize
187 !< partition of cell over which to integrate for
188 !! interpolated grounding line the (rectangular) is
189 !! divided into nxn equally-sized rectangles, over which
190 !! basal contribution is integrated (iterative quadrature)
191 logical :: gl_couple !< whether to let the floatation condition be
192 !! determined by ocean column thickness means update_OD_ffrac
193 !! will be called (note: GL_regularize and GL_couple
194 !! should be exclusive)
195
196 real :: cfl_factor !< A factor used to limit subcycled advective timestep in uncoupled runs
197 !! i.e. dt <= CFL_factor * min(dx / u) [nondim]
198
199 real :: min_h_shelf !< The minimum ice thickness used during ice dynamics [Z ~> m].
200 real :: min_basal_traction !< The minimum basal traction for grounded ice (Pa m-1 s) [R Z T-1 ~> kg m-2 s-1]
201 real :: max_surface_slope !< The maximum allowed ice-sheet surface slope (to ignore, set to zero) [nondim]
202 real :: min_ice_visc !< The minimum allowed Glen's law ice viscosity (Pa s), in [R L2 T-1 ~> kg m-1 s-1].
203
204 real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim]
205 real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1].
206 real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim]
207 logical :: coulombfriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007)
208 real :: cf_minn !< Minimum Coulomb friction effective pressure [R Z L T-2 ~> Pa]
209 real :: cf_postpeak !< Coulomb friction post peak exponent [nondim]
210 real :: cf_max !< Coulomb friction maximum coefficient [nondim]
211 real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean
212 !! circulation or thermodynamics. It is used to estimate the
213 !! gravitational driving force at the shelf front (until we think of
214 !! a better way to do it, but any difference will be negligible).
215 real :: rhoi_rhow !< The density of ice divided by a typical water density [nondim]
216 real :: rhow_rhoi !< A typical water density divided by the density of ice [nondim]
217 real :: thresh_float_col_depth !< The water column depth over which the shelf if considered to be floating
218 logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve).
219 logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask.
220 real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m].
221 real :: t_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC]
222 real :: cg_tolerance !< For Picard iterations, the tolerance in the CG solver, relative to initial residual, that
223 !! determines when to stop the conjugate gradient iterations [nondim].
224 real :: cg_newton_tolerance !< For inexact Newton iterations, the initial tolerance in the CG solver, relative to
225 !! initial residual, that determines when to stop the CG iterations [nondim].
226 real :: cg_tol_current !< Working CG tolerance for the current inner solve [nondim].
227 real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error,
228 !! that sets when to stop the iterative velocity solver [nondim]
229 real :: newton_after_tolerance !< The fractional nonlinear tolerance, relative to the initial error, at
230 !! which to switch from Picard to Newton iterations in the velocity solver
231 !! If set to <= 0, no Picard [nondim]
232 type(group_pass_type) :: pass_visc_and_newton !< Handle for Newton-and-viscosity-related group passes
233 type(group_pass_type) :: pass_newton !< Handle for Newton-related group passes
234 logical :: newton_divergence_rescue !< If true, monitor the nonlinear residual while Newton is
235 !! active and, on divergence (residual NaN or exceeding
236 !! newton_divergence_factor times its value at the Picard-to-
237 !! Newton switch), restore the pre-Newton iterate, revert to
238 !! Picard with a fresh outer-iteration budget, and reduce the
239 !! switch threshold tenfold for the remainder of this solve.
240 real :: newton_divergence_factor !< Factor on the nonlinear residual at the Picard-to-Newton
241 !! switch above which the Newton iteration is declared
242 !! divergent and rescued [nondim].
243 integer :: newton_max_rescues !< Maximum number of divergence rescues per velocity solve;
244 !! once reached, Newton is disabled and the remainder of the
245 !! solve runs pure Picard [nondim]
246 logical :: newton_adapt_cg_tol !< Use an adaptive CG tolerance during Newton iterations
247 real :: ew_gamma !< Gamma in Eisenstat-Walker adaptive Newton tolerance [nondim].
248 real :: ew_alpha !< Alpha in Eisenstat-Walker adaptive Newton tolerance [nondim].
249 integer :: ew_safety !< Safeguard Eisenstat-Walker using:
250 !!(0) no safeguard, (1) EW choice 2 threshold or (2) PETSc option 3 (Chacon 2008)
251 real :: ew_1_thres !< Threshold for Eisenstat-Walker version 1 [nondim]
252 real :: ew_eta_max !< Maximum allowed Eisenstat-Walker eta [nondim]
253 integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver
254 integer :: nonlin_solve_err_mode !< 1: exit based on nonlin residual | F | / | F_0 | where | | is infty-norm
255 !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm
256 !! 3: exit based on change of solution norm 2*abs(|u|-|u_last|)/(|u|+|u_last|) where | | is L2-norm
257 !! 4: exit based on nonlin residual | F | / | F_0 | where | | is L2-norm
258 !! 5: exit based on relative residual | F | / | tau | where | | is L2-norm
259 logical :: ssa_add_rel_resid !< Nonlinear error in velocity solve will also depend on the
260 !! L2 residual norm relative to RHS norm
261 real :: rr_nonlinear_tolerance !< If ssa_add_rel_resid, the additional nonlin tolerance in the iterative
262 !! velocity solve used for the relative residual [nondim]
263 ! for write_ice_shelf_energy
264 type(time_type) :: energysavedays !< The interval between writing the energies
265 !! and other integral quantities of the run.
266 type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric
267 !! progression of time deltas between calls to
268 !! write_energy. This interval will increase by a factor of 2.
269 !! after each call to write_energy.
270 logical :: energysave_geometric !< Logical to control whether calls to write_energy should
271 !! follow a geometric progression
272 type(time_type) :: write_energy_time !< The next time to write to the energy file.
273 type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression
274 !! of calls to write_energy and revert to the standard
275 !! energysavedays interval
276 real :: timeunit !< The length of the units for the time axis and certain input parameters
277 !! including ENERGYSAVEDAYS [s].
278 type(time_type) :: start_time !< The start time of the simulation.
279 ! Start_time is set in MOM_initialization.F90
280 integer :: prev_is_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called.
281 integer :: is_fileenergy_ascii = -1
282 !< The unit number of the ascii version of the energy file.
283 character(len=200) :: is_energyfile !< The name of the ice sheet energy file with path.
284
285 ! ids for outputting intermediate thickness in advection subroutine (debugging)
286 !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1
287
288 logical :: debug !< If true, write verbose checksums for debugging purposes
289 !! and use reproducible sums
290 logical :: doing_newton = .false. !< If true, the outer iteration is using Newton (tangent) linearization
291 !! instead of Picard (secant) linearization for the ice viscosity
292 integer :: inner_solver !< The inner linear solver: INNER_CG (1),INNER_MINRES (2), or INNER_CR (3)
293 logical :: cg_halo_shrink = .true. !< If true, CG uses halo-shrinking to defer pass_vector calls;
294 !! if false, uses fixed CG_action range with 1 pass_vector per iteration
295 logical :: module_is_initialized = .false. !< True if this module has been initialized.
296
297 !>@{ Diagnostic handles
298 integer :: id_u_shelf = -1, id_v_shelf = -1, id_shelf_speed, id_t_shelf = -1, &
299 id_taudx_shelf = -1, id_taudy_shelf = -1, id_taud_shelf = -1, id_bed_elev = -1, &
300 id_ground_frac = -1, id_col_thick = -1, id_od_av = -1, id_float_cond = -1, &
301 id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1, &
302 id_sx_shelf = -1, id_sy_shelf = -1, id_surf_slope_mag_shelf, &
303 id_duhdx = -1, id_dvhdy = -1, id_fluxdiv = -1, &
304 id_strainrate_xx = -1, id_strainrate_yy = -1, id_strainrate_xy = -1, &
305 id_pstrainrate_1 = -1, id_pstrainrate_2, &
306 id_devstress_xx = -1, id_devstress_yy = -1, id_devstress_xy = -1, &
307 id_pdevstress_1 = -1, id_pdevstress_2 = -1
308
309 !>@}
310 ! ids for outputting intermediate thickness in advection subroutine (debugging)
311 !>@{ Diagnostic handles for debugging
312 integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, &
313 id_visc_shelf = -1, id_taub = -1
314 !>@}
315 type(diag_ctrl), pointer :: diag => null() !< A structure that is used to control diagnostic output.
316
317end type ice_shelf_dyn_cs
318
319!> A container for loop bounds
320type :: loop_bounds_type ; private
321 integer :: ish !< Starting i-index of the computational domain [nondim]
322 integer :: ieh !< Ending i-index of the computational domain [nondim]
323 integer :: jsh !< Starting j-index of the computational domain [nondim]
324 integer :: jeh !< Ending j-index of the computational domain [nondim]
325end type loop_bounds_type
326
327contains
328
329!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia)
330!! The return value is between 0 and 2 [nondim].
331function slope_limiter(num, denom)
332 real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter
333 real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter
334 real :: slope_limiter ! The slope limiter value, between 0 and 2 [nondim].
335 real :: r ! The ratio of num/denom [nondim]
336
337 if (denom == 0) then
338 slope_limiter = 0
339 elseif (num*denom <= 0) then
340 slope_limiter = 0
341 else
342 r = num/denom
343 slope_limiter = (r+abs(r))/(1+abs(r))
344 endif
345
346end function slope_limiter
347
348!> Calculate area of quadrilateral.
349function quad_area (X, Y)
350 real, dimension(4), intent(in) :: x !< The x-positions of the vertices of the quadrilateral [L ~> m].
351 real, dimension(4), intent(in) :: y !< The y-positions of the vertices of the quadrilateral [L ~> m].
352 real :: quad_area ! Computed area [L2 ~> m2]
353 real :: p2, q2, a2, c2, b2, d2
354
355! X and Y must be passed in the form
356 ! 3 - 4
357 ! | |
358 ! 1 - 2
359
360 p2 = ( ((x(4)-x(1))**2) + ((y(4)-y(1))**2) ) ; q2 = ( ((x(3)-x(2))**2) + ((y(3)-y(2))**2) )
361 a2 = ( ((x(3)-x(4))**2) + ((y(3)-y(4))**2) ) ; c2 = ( ((x(1)-x(2))**2) + ((y(1)-y(2))**2) )
362 b2 = ( ((x(2)-x(4))**2) + ((y(2)-y(4))**2) ) ; d2 = ( ((x(3)-x(1))**2) + ((y(3)-y(1))**2) )
363 quad_area = .25 * sqrt(4*p2*q2-(b2+d2-a2-c2)**2)
364
365end function quad_area
366
367!> This subroutine is used to register any fields related to the ice shelf
368!! dynamics that should be written to or read from the restart file.
369subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS)
370 type(ocean_grid_type), intent(inout) :: g !< The grid type describing the ice shelf grid.
371 type(unit_scale_type), intent(in) :: us !< A structure containing unit conversion factors
372 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters
373 type(ice_shelf_dyn_cs), pointer :: cs !< A pointer to the ice shelf dynamics control structure
374 type(mom_restart_cs), intent(inout) :: restart_cs !< MOM restart control struct
375
376 ! Local variables
377 real :: t_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [C ~> degC]
378 logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics
379 character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name.
380 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
381
382 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
383 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
384
385 if (associated(cs)) then
386 call mom_error(fatal, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// &
387 "called with an associated control structure.")
388 return
389 endif
390 allocate(cs)
391
392 override_shelf_movement = .false. ; active_shelf_dynamics = .false.
393 call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, &
394 "If true, the ice sheet mass can evolve with time.", &
395 default=.false., do_not_log=.true.)
396 if (shelf_mass_is_dynamic) then
397 call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, &
398 "If true, user provided code specifies the ice-shelf "//&
399 "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.)
400 active_shelf_dynamics = .not.override_shelf_movement
401 endif
402
403 if (active_shelf_dynamics) then
404 call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", t_shelf_missing, &
405 "An ice shelf temperature to use where there is no ice shelf.",&
406 units="degC", default=-10.0, scale=us%degC_to_C, do_not_log=.true.)
407
408 call get_param(param_file, mdl, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS", cs%visc_qps, &
409 "Number of ice viscosity quadrature points. Either 1 (cell-centered) for 4", &
410 units="none", default=4)
411 if (cs%visc_qps/=1 .and. cs%visc_qps/=4) call mom_error (fatal, &
412 "NUMBER OF ICE_VISCOSITY_QUADRATURE_POINTS must be 1 or 4")
413
414 call get_param(param_file, mdl, "FIRST_DIRECTION_IS", cs%first_direction_IS, &
415 "An integer that indicates which direction goes first "//&
416 "in parts of the code that use directionally split "//&
417 "updates (e.g. advection), with even numbers (or 0) used for x- first "//&
418 "and odd numbers used for y-first.", default=0)
419 call get_param(param_file, mdl, "ALTERNATE_FIRST_DIRECTION_IS", cs%alternate_first_direction_IS, &
420 "If true, after every advection call, alternate whether the x- or y- "//&
421 "direction advection updates occur first. "//&
422 "If this is true, FIRST_DIRECTION applies at the start of a new run or if "//&
423 "the next first direction can not be found in the restart file.", default=.false.)
424
425 allocate(cs%u_shelf(isdb:iedb,jsdb:jedb), source=0.0)
426 allocate(cs%v_shelf(isdb:iedb,jsdb:jedb), source=0.0)
427 allocate(cs%t_shelf(isd:ied,jsd:jed), source=t_shelf_missing) ! [C ~> degC]
428 allocate(cs%ice_visc(isd:ied,jsd:jed,cs%visc_qps), source=0.0)
429 allocate(cs%newton_visc_factor(isd:ied,jsd:jed,cs%visc_qps), source=0.0)
430 allocate(cs%newton_str_ux(isd:ied,jsd:jed,cs%visc_qps), source=0.0)
431 allocate(cs%newton_str_vy(isd:ied,jsd:jed,cs%visc_qps), source=0.0)
432 allocate(cs%newton_str_sh(isd:ied,jsd:jed,cs%visc_qps), source=0.0)
433 allocate(cs%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1]
434 allocate(cs%C_basal_friction(isd:ied,jsd:jed), source=5.0e10*us%Pa_to_RLZ_T2)
435 ! Units of [R L Z T-2 (s m-1)^n_sliding ~> Pa (s m-1)^n_sliding]
436 allocate(cs%coef_prefactor(isd:ied,jsd:jed), source=0.0)
437 allocate(cs%fB_elem(isd:ied,jsd:jed), source=0.0)
438 allocate(cs%OD_av(isd:ied,jsd:jed), source=0.0)
439 allocate(cs%ground_frac(isd:ied,jsd:jed), source=0.0)
440 allocate(cs%taudx_shelf(isdb:iedb,jsdb:jedb), source=0.0)
441 allocate(cs%taudy_shelf(isdb:iedb,jsdb:jedb), source=0.0)
442 allocate(cs%sx_shelf(isd:ied,jsd:jed), source=0.0)
443 allocate(cs%sy_shelf(isd:ied,jsd:jed), source=0.0)
444 allocate(cs%bed_elev(isd:ied,jsd:jed), source=0.0)
445 allocate(cs%u_bdry_val(isdb:iedb,jsdb:jedb), source=0.0)
446 allocate(cs%v_bdry_val(isdb:iedb,jsdb:jedb), source=0.0)
447 allocate(cs%u_face_mask_bdry(isdb:iedb,jsdb:jedb), source=-2.0)
448 allocate(cs%v_face_mask_bdry(isdb:iedb,jsdb:jedb), source=-2.0)
449 allocate(cs%h_bdry_val(isd:ied,jsd:jed), source=0.0)
450
451 ! Create group pass handles
452 call create_group_pass(cs%pass_visc_and_newton, cs%ice_visc, g%domain)
453 call create_group_pass(cs%pass_visc_and_newton, cs%newton_str_sh, g%domain)
454 call create_group_pass(cs%pass_visc_and_newton, cs%newton_visc_factor, g%domain)
455 call create_group_pass(cs%pass_visc_and_newton, cs%newton_str_ux, cs%newton_str_vy, g%domain, to_all, agrid)
456
457 call create_group_pass(cs%pass_newton, cs%newton_str_sh, g%domain)
458 call create_group_pass(cs%pass_newton, cs%newton_visc_factor, g%domain)
459 call create_group_pass(cs%pass_newton, cs%newton_str_ux, cs%newton_str_vy, g%domain, to_all, agrid)
460
461 ! additional restarts for ice shelf state
462 call register_restart_field(cs%u_shelf, "u_shelf", .false., restart_cs, &
463 "ice sheet/shelf u-velocity", &
464 units="m s-1", conversion=us%L_T_to_m_s, hor_grid='Bu')
465 call register_restart_field(cs%v_shelf, "v_shelf", .false., restart_cs, &
466 "ice sheet/shelf v-velocity", &
467 units="m s-1", conversion=us%L_T_to_m_s, hor_grid='Bu')
468 call register_restart_field(cs%u_bdry_val, "u_bdry_val", .false., restart_cs, &
469 "ice sheet/shelf boundary u-velocity", &
470 units="m s-1", conversion=us%L_T_to_m_s, hor_grid='Bu')
471 call register_restart_field(cs%v_bdry_val, "v_bdry_val", .false., restart_cs, &
472 "ice sheet/shelf boundary v-velocity", &
473 units="m s-1", conversion=us%L_T_to_m_s, hor_grid='Bu')
474 call register_restart_field(cs%u_face_mask_bdry, "u_face_mask_bdry", .false., restart_cs, &
475 "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu')
476 call register_restart_field(cs%v_face_mask_bdry, "v_face_mask_bdry", .false., restart_cs, &
477 "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu')
478
479 call register_restart_field(cs%OD_av, "OD_av", .true., restart_cs, &
480 "Average open ocean depth in a cell", "m", conversion=us%Z_to_m)
481 call register_restart_field(cs%ground_frac, "ground_frac", .true., restart_cs, &
482 "fractional degree of grounding", "nondim")
483 call register_restart_field(cs%C_basal_friction, "C_basal_friction", .true., restart_cs, &
484 "basal sliding coefficients", "Pa (s m-1)^n_sliding", conversion=us%RLZ_T2_to_Pa)
485 call register_restart_field(cs%AGlen_visc, "AGlen_visc", .true., restart_cs, &
486 "ice-stiffness parameter", "Pa-3 s-1")
487 call register_restart_field(cs%h_bdry_val, "h_bdry_val", .false., restart_cs, &
488 "ice thickness at the boundary", "m", conversion=us%Z_to_m)
489 call register_restart_field(cs%bed_elev, "bed elevation", .true., restart_cs, &
490 "bed elevation", "m", conversion=us%Z_to_m)
491 call register_restart_field(cs%first_dir_restart_IS, "first_direction_IS", .false., restart_cs, &
492 "Indicator of the first direction in split ice shelf calculations.", "nondim")
493 endif
494
496
497!> Initializes shelf model data, parameters and diagnostics
498subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, Cp_ice, &
499 Input_start_time, directory, solo_ice_sheet_in)
500 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters
501 type(time_type), intent(inout) :: time !< The clock that that will indicate the model time
502 type(ice_shelf_state), intent(in) :: iss !< A structure with elements that describe
503 !! the ice-shelf state
504 type(ice_shelf_dyn_cs), pointer :: cs !< A pointer to the ice shelf dynamics control structure
505 type(ocean_grid_type), intent(inout) :: g !< The grid type describing the ice shelf grid.
506 type(unit_scale_type), intent(in) :: us !< A structure containing unit conversion factors
507 type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output.
508 logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise
509 !! has been started from a restart file.
510 real, intent(in) :: cp_ice !< Heat capacity of ice [Q C-1 ~> J kg-1 degC-1]
511 type(time_type), intent(in) :: input_start_time !< The start time of the simulation.
512 character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes.
513 logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether
514 !! a solo ice-sheet driver.
515
516 ! Local variables
517 real :: t_shelf_bdry ! A default ice shelf temperature to use for ice flowing
518 ! in through open boundaries [C ~> degC]
519 !This include declares and sets the variable "version".
520# include "version_variable.h"
521 character(len=200) :: ic_file, filename, inputdir
522 character(len=40) :: var_name
523 character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name.
524 logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics
525 logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
526 ! recreate the bugs, or if false bugs are only used if actively selected.
527 logical :: debug
528 integer :: i, j, isd, ied, jsd, jed, isdq, iedq, jsdq, jedq, iters
529 character(len=200) :: is_energyfile ! The name of the energy file.
530 character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs
531 character(len=16) :: inner_solver_str ! The type of inner solver to use for the SSA
532
533 isdq = g%isdB ; iedq = g%iedB ; jsdq = g%jsdB ; jedq = g%jedB
534 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
535
536 if (.not.associated(cs)) then
537 call mom_error(fatal, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// &
538 "called with an associated control structure.")
539 return
540 endif
541 if (cs%module_is_initialized) then
542 call mom_error(warning, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//&
543 "called with a control structure that has already been initialized.")
544 endif
545 cs%module_is_initialized = .true.
546
547 cs%diag => diag ! ; CS%Time => Time
548
549 ! Read all relevant parameters and write them to the model log.
550 call log_version(param_file, mdl, version, "")
551 call get_param(param_file, mdl, "DEBUG", debug, default=.false.)
552 call get_param(param_file, mdl, "DEBUG_IS", cs%debug, &
553 "If true, write verbose debugging messages for the ice shelf.", &
554 default=debug)
555 call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, &
556 "If true, the ice sheet mass can evolve with time.", &
557 default=.false.)
558 override_shelf_movement = .false. ; active_shelf_dynamics = .false.
559 if (shelf_mass_is_dynamic) then
560 call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, &
561 "If true, user provided code specifies the ice-shelf "//&
562 "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.)
563 active_shelf_dynamics = .not.override_shelf_movement
564
565 call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", cs%GL_regularize, &
566 "If true, regularize the floatation condition at the "//&
567 "grounding line as in Goldberg Holland Schoof 2009.", default=.false.)
568 call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", cs%n_sub_regularize, &
569 "The number of sub-partitions of each cell over which to "//&
570 "integrate for the interpolated grounding line. Each cell "//&
571 "is divided into NxN equally-sized rectangles, over which the "//&
572 "basal contribution is integrated by iterative quadrature.", &
573 default=0)
574 call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", cs%GL_couple, &
575 "If true, let the floatation condition be determined by "//&
576 "ocean column thickness. This means that update_OD_ffrac "//&
577 "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", &
578 default=.false., do_not_log=cs%GL_regularize)
579 if (cs%GL_regularize) cs%GL_couple = .false.
580 if (present(solo_ice_sheet_in)) then
581 if (solo_ice_sheet_in) cs%GL_couple = .false.
582 endif
583 if (cs%GL_regularize .and. (cs%n_sub_regularize == 0)) call mom_error (fatal, &
584 "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used")
585 call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", cs%CFL_factor, &
586 "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//&
587 "This is only used with an ice-only model.", units="nondim", default=0.25)
588 endif
589 call get_param(param_file, mdl, "RHO_0", cs%density_ocean_avg, &
590 "avg ocean density used in floatation cond", &
591 units="kg m-3", default=1035., scale=us%kg_m3_to_R)
592 if (active_shelf_dynamics) then
593 call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", cs%velocity_update_time_step, &
594 "seconds between ice velocity calcs", units="s", scale=us%s_to_T, &
595 fail_if_missing=.true.)
596 call get_param(param_file, mdl, "G_EARTH", cs%g_Earth, &
597 "The gravitational acceleration of the Earth.", &
598 units="m s-2", default=9.80, scale=us%m_s_to_L_T**2*us%Z_to_m)
599
600 call get_param(param_file, mdl, "MIN_H_SHELF", cs%min_h_shelf, &
601 "min. ice thickness used during ice dynamics", &
602 units="m", default=0.,scale=us%m_to_Z)
603 call get_param(param_file, mdl, "MIN_BASAL_TRACTION", cs%min_basal_traction, &
604 "min. allowed basal traction. Input is in [Pa m-1 yr], but is converted when read in to [Pa m-1 s]", &
605 units="Pa m-1 yr", default=0., scale=365.0*86400.0*us%Pa_to_RLZ_T2*us%L_T_to_m_s)
606 call get_param(param_file, mdl, "MAX_SURFACE_SLOPE", cs%max_surface_slope, &
607 "max. allowed ice-sheet surface slope. To ignore, set to zero.", &
608 units="none", default=0., scale=us%m_to_Z/us%m_to_L)
609 call get_param(param_file, mdl, "MIN_ICE_VISC", cs%min_ice_visc, &
610 "min. allowed Glen's law ice viscosity", &
611 units="Pa s", default=0., scale=us%Pa_to_RL2_T2*us%s_to_T)
612
613 call get_param(param_file, mdl, "GLEN_EXPONENT", cs%n_glen, &
614 "nonlinearity exponent in Glen's Law", &
615 units="none", default=3.)
616 call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", cs%eps_glen_min, &
617 "min. strain rate to avoid infinite Glen's law viscosity", &
618 units="s-1", default=1.e-19, scale=us%T_to_s)
619 call get_param(param_file, mdl, "BASAL_FRICTION_EXP", cs%n_basal_fric, &
620 "Exponent in sliding law \tau_b = C u^(n_basal_fric)", &
621 units="none", fail_if_missing=.true.)
622 call get_param(param_file, mdl, "USE_COULOMB_FRICTION", cs%CoulombFriction, &
623 "Use Coulomb Friction Law", &
624 units="none", default=.false., fail_if_missing=.false.)
625 call get_param(param_file, mdl, "CF_MinN", cs%CF_MinN, &
626 "Minimum Coulomb friction effective pressure", &
627 units="Pa", default=1.0, scale=us%Pa_to_RLZ_T2, fail_if_missing=.false.)
628 call get_param(param_file, mdl, "CF_PostPeak", cs%CF_PostPeak, &
629 "Coulomb friction post peak exponent", &
630 units="none", default=1.0, fail_if_missing=.false.)
631 call get_param(param_file, mdl, "CF_Max", cs%CF_Max, &
632 "Coulomb friction maximum coefficient", &
633 units="none", default=0.5, fail_if_missing=.false.)
634 ! Pre-compute Coulomb prefactor alpha = (q-1)^(q-1)/q^q for q=CF_PostPeak [nondim].
635 ! Default is 1.0; only update when Coulomb is active and q /= 1.
636 ! Also store CS%coulomb_pp_n = CF_PostPeak/n_basal_fric [nondim]
637 if (cs%CoulombFriction) then
638 if (cs%CF_PostPeak /= 1.0) then
639 cs%alpha_coulomb = (cs%CF_PostPeak-1.0)**(cs%CF_PostPeak-1.0) / cs%CF_PostPeak**cs%CF_PostPeak
640 endif
641 cs%coulomb_pp_n = cs%CF_PostPeak/cs%n_basal_fric
642 endif
643
644 call get_param(param_file, mdl, "DENSITY_ICE", cs%density_ice, &
645 "A typical density of ice.", units="kg m-3", default=917.0, scale=us%kg_m3_to_R)
646
647 ! Precompute commonly-used density ratios
648 cs%rhoi_rhow=cs%density_ice / cs%density_ocean_avg
649 cs%rhow_rhoi=cs%density_ocean_avg / cs%density_ice
650
651 call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", cs%cg_tolerance, &
652 "For Picard iterations, the tolerance in CG solver, relative to initial residual", &
653 units="nondim", default=1.e-6)
654 call get_param(param_file, mdl, "NEWTON_CONJUGATE_GRADIENT_TOLERANCE", cs%cg_newton_tolerance, &
655 "For inexact Newton iterations, the initial tolerance in CG solver, relative to initial residual", &
656 units="nondim", default=cs%cg_tolerance)
657 cs%cg_tol_current = cs%cg_tolerance ! Can be tightened adaptively during inexact Newton iterations
658 call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", cs%nonlinear_tolerance, &
659 "nonlin tolerance in iterative velocity solve", units="nondim", default=1.e-6)
660 call get_param(param_file, mdl, "NEWTON_AFTER_TOLERANCE", cs%newton_after_tolerance, &
661 "Switch from Picard to Newton iterations in the nonlinear ice velocity solve when "//&
662 "the fractional nonlinear residual falls below this tolerance. If <=0, no Picard.",&
663 units="none", default=cs%nonlinear_tolerance)
664 call get_param(param_file, mdl, "NEWTON_DIVERGENCE_RESCUE", cs%newton_divergence_rescue, &
665 "If true, monitor the nonlinear residual while Newton iterations are active "//&
666 "and, if it becomes NaN or exceeds NEWTON_DIVERGENCE_FACTOR times its value "//&
667 "at the Picard-to-Newton switch, restore the pre-Newton velocity iterate, "//&
668 "revert to Picard iterations with a fresh outer-iteration budget, and reduce "//&
669 "the Picard-to-Newton switch threshold by a factor of 10 for the remainder "//&
670 "of this velocity solve (the configured NEWTON_AFTER_TOLERANCE is restored "//&
671 "at the next solve). At most NEWTON_DIVERGENCE_MAX_RESCUES rescues are "//&
672 "attempted per solve, after which Newton is disabled and the solve "//&
673 "completes as pure Picard. No effect when NEWTON_AFTER_TOLERANCE <= 0.", &
674 default=.false.)
675 call get_param(param_file, mdl, "NEWTON_DIVERGENCE_FACTOR", cs%newton_divergence_factor, &
676 "Factor on the nonlinear residual at the Picard-to-Newton switch above "//&
677 "which the Newton iteration is declared divergent and rescued.", &
678 units="nondim", default=10.0, do_not_log=.not.cs%newton_divergence_rescue)
679 call get_param(param_file, mdl, "NEWTON_DIVERGENCE_MAX_RESCUES", cs%newton_max_rescues, &
680 "Maximum number of Newton divergence rescues per velocity solve. Once "//&
681 "reached, Newton is disabled (the working switch threshold is set to "//&
682 "zero) and the remainder of the solve runs pure Picard.", &
683 units="nondim", default=2, do_not_log=.not.cs%newton_divergence_rescue)
684 call get_param(param_file, mdl, "NEWTON_ADAPT_CG_TOL", cs%newton_adapt_cg_tol, &
685 "Use an adaptive CG tolerance during Newton iterations.", default=.true.)
686 call get_param(param_file, mdl, "NEWTON_EW_GAMMA", cs%ew_gamma, &
687 "Gamma in Eisenstat-Walker adaptive Newton tolerance", units="nondim", default=0.9, &
688 do_not_log=(.not. cs%newton_adapt_cg_tol))
689 call get_param(param_file, mdl, "NEWTON_EW_ALPHA", cs%ew_alpha, &
690 "Alpha in Eisenstat-Walker adaptive Newton tolerance", units="nondim", default=2.0, &
691 do_not_log=(.not. cs%newton_adapt_cg_tol))
692 call get_param(param_file, mdl, "NEWTON_EW_SAFETY", cs%ew_safety, &
693 "Safeguard Eisenstat-Walker using (0) no safeguard, (1) EW choice 2 threshold "//&
694 "or (2) PETSc option 3 (Chacon 2008)", default=2, do_not_log=(.not. cs%newton_adapt_cg_tol))
695 call get_param(param_file, mdl, "NEWTON_EW_1_THRESHOLD", cs%ew_1_thres, &
696 "Eisenstat-Walker version 1 threshold", &
697 units="nondim", default=0.1, do_not_log=(.not. cs%newton_adapt_cg_tol))
698 call get_param(param_file, mdl, "NEWTON_EW_ETA_MAX", cs%ew_eta_max, &
699 "Maximum allowed Eisenstat-Walker eta (between 0 and 1)", &
700 units="nondim", default=0.9, do_not_log=(.not. cs%newton_adapt_cg_tol))
701 if (cs%ew_eta_max<=0 .or. cs%ew_eta_max>= 1) &
702 call mom_error(fatal, "NEWTON_EW_ETA_MAX must be between 0 and 1.")
703 call get_param(param_file, mdl, "ICE_SHELF_INNER_SOLVER", inner_solver_str, &
704 "Choice of inner linear solver for the ice-shelf SSA velocity system. "//&
705 "Valid choices are CG (default), CR, and MINRES.", &
706 default="CG")
707 select case (trim(inner_solver_str))
708 case ("CG")
709 cs%inner_solver = inner_cg
710 case ("MINRES")
711 cs%inner_solver = inner_minres
712 case ("CR")
713 cs%inner_solver = inner_cr
714 end select
715 call get_param(param_file, mdl, "CG_HALO_SHRINK", cs%cg_halo_shrink, &
716 "If true, CG uses halo-shrinking to defer pass_vector calls. "//&
717 "If false, uses a fixed CG_action range with one pass_vector(D) per iteration, "//&
718 "which may reduce total communication for typical halo widths.", &
719 default=.true.)
720 call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", cs%cg_max_iterations, &
721 "max iteratiions in CG solver", default=2000)
722 call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", cs%thresh_float_col_depth, &
723 "min ocean thickness to consider ice *floating*; "//&
724 "will only be important with use of tides", &
725 units="m", default=1.e-3, scale=us%m_to_Z)
726 call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", cs%nonlin_solve_err_mode, &
727 "Choose whether nonlin error in vel solve is based on nonlinear "//&
728 "Linf norm residual (1), Linf norm relative change since last iteration (2), "//&
729 "change in solution L2 norm (3), L2 norm residual (4), L2 backward norm (5)", default=3)
730 if (cs%nonlin_solve_err_mode /= 5) then
731 call get_param(param_file, mdl, "SSA_ADD_REL_RESID", cs%ssa_add_rel_resid, &
732 "Nonlinear error in vel solve will also depend on "// &
733 "L2 residual norm relative to RHS norm.", default=.false.)
734 else
735 cs%ssa_add_rel_resid = .false. !Avoids redundantly calculating err_mode 5 twice
736 endif
737 call get_param(param_file, mdl, "ICE_RR_NONLINEAR_TOLERANCE", cs%rr_nonlinear_tolerance, &
738 "if ssa_add_rel_resid, the additional nonlin tolerance "//&
739 "in the iterative velocity solve for the residual norm relative to RHS norm", &
740 units="nondim", default=1.e-4)
741 call get_param(param_file, mdl, "SHELF_MOVING_FRONT", cs%moving_shelf_front, &
742 "Specify whether to advance shelf front (and calve).", &
743 default=.false.)
744 call get_param(param_file, mdl, "CALVE_TO_MASK", cs%calve_to_mask, &
745 "If true, do not allow an ice shelf where prohibited by a mask.", &
746 default=.false.)
747 call get_param(param_file, mdl, "ADVECT_SHELF", cs%advect_shelf, &
748 "If true, advect ice shelf and evolve thickness", &
749 default=.true.)
750 call get_param(param_file, mdl, "REENTRANT_X", cs%reentrant_x, &
751 " If true, the domain is zonally reentrant.", &
752 default=.false.)
753 call get_param(param_file, mdl, "REENTRANT_Y", cs%reentrant_y, &
754 " If true, the domain is meridionally reentrant.", &
755 default=.false.)
756 call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", cs%ice_viscosity_compute, &
757 "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points, "//&
758 "if OBS read from a file, "//&
759 "if CONSTANT a constant value (for debugging).", &
760 default="MODEL")
761
762 call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
763 default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
764 call get_param(param_file, mdl, "ICE_SHELF_TOP_SLOPE_BUG", cs%shelf_top_slope_bugs, &
765 "If true, use directionally inconsistent estimates of the grid spacing when "//&
766 "calculating the ice shelf surface slope, and underestimate slopes near the "//&
767 "edge of the ice shelf by a factor of 2.", default=enable_bugs)
768
769 if ((cs%visc_qps/=1) .and. (trim(cs%ice_viscosity_compute) /= "MODEL")) then
770 call mom_error(fatal, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS must be 1 unless ICE_VISCOSITY_COMPUTE==MODEL.")
771 endif
772 call get_param(param_file, mdl, "INFLOW_SHELF_TEMPERATURE", t_shelf_bdry, &
773 "A default ice shelf temperature to use for ice flowing in through "//&
774 "open boundaries.", units="degC", default=-15.0, scale=us%degC_to_C)
775 endif
776 call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", cs%T_shelf_missing, &
777 "An ice shelf temperature to use where there is no ice shelf.",&
778 units="degC", default=-10.0, scale=us%degC_to_C)
779 call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", cs%min_thickness_simple_calve, &
780 "Min thickness rule for the VERY simple calving law",&
781 units="m", default=0.0, scale=us%m_to_Z)
782 cs%Cp_ice = cp_ice !Heat capacity of ice (J kg-1 K-1), needed for heat flux of any bergs calved from
783 !the ice shelf and for ice sheet temperature solver
784 !for write_ice_shelf_energy
785 ! Note that the units of CS%Timeunit are the MKS units of [s].
786 call get_param(param_file, mdl, "TIMEUNIT", cs%Timeunit, &
787 "The time unit in seconds a number of input fields", &
788 units="s", default=86400.0)
789 if (cs%Timeunit < 0.0) cs%Timeunit = 86400.0
790 call get_param(param_file, mdl, "ENERGYSAVEDAYS",cs%energysavedays, &
791 "The interval in units of TIMEUNIT between saves of the "//&
792 "energies of the run and other globally summed diagnostics.",&
793 default=set_time(0,days=1), timeunit=cs%Timeunit)
794 call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",cs%energysavedays_geometric, &
795 "The starting interval in units of TIMEUNIT for the first call "//&
796 "to save the energies of the run and other globally summed diagnostics. "//&
797 "The interval increases by a factor of 2. after each call to write_ice_shelf_energy.",&
798 default=set_time(seconds=0), timeunit=cs%Timeunit)
799 if ((time_type_to_real(cs%energysavedays_geometric) > 0.) .and. &
800 (cs%energysavedays_geometric < cs%energysavedays)) then
801 cs%energysave_geometric = .true.
802 else
803 cs%energysave_geometric = .false.
804 endif
805 cs%Start_time = input_start_time
806 call get_param(param_file, mdl, "ICE_SHELF_ENERGYFILE", is_energyfile, &
807 "The file to use to write the energies and globally "//&
808 "summed diagnostics.", default="ice_shelf.stats")
809 !query fms_io if there is a filename_appendix (for ensemble runs)
810 call get_filename_appendix(filename_appendix)
811 if (len_trim(filename_appendix) > 0) then
812 is_energyfile = trim(is_energyfile) //'.'//trim(filename_appendix)
813 endif
814
815 cs%IS_energyfile = trim(slasher(directory))//trim(is_energyfile)
816 call log_param(param_file, mdl, "output_path/ENERGYFILE", cs%IS_energyfile)
817#ifdef STATSLABEL
818 cs%IS_energyfile = trim(cs%IS_energyfile)//"."//trim(adjustl(statslabel))
819#endif
820
821 ! Allocate memory in the ice shelf dynamics control structure that was not
822 ! previously allocated for registration for restarts.
823
824 if (active_shelf_dynamics) then
825 allocate( cs%t_bdry_val(isd:ied,jsd:jed), source=t_shelf_bdry) ! [C ~> degC]
826 allocate( cs%u_face_mask(isdq:iedq,jsdq:jedq), source=0.0)
827 allocate( cs%v_face_mask(isdq:iedq,jsdq:jedq), source=0.0)
828 allocate( cs%u_flux_bdry_val(isdq:iedq,jsd:jed), source=0.0)
829 allocate( cs%v_flux_bdry_val(isd:ied,jsdq:jedq), source=0.0)
830 allocate( cs%umask(isdq:iedq,jsdq:jedq), source=-1.0)
831 allocate( cs%vmask(isdq:iedq,jsdq:jedq), source=-1.0)
832 allocate( cs%tmask(isdq:iedq,jsdq:jedq), source=-1.0)
833 allocate( cs%float_cond(isd:ied,jsd:jed))
834
835 cs%OD_rt_counter = 0
836 allocate( cs%OD_rt(isd:ied,jsd:jed), source=0.0)
837 allocate( cs%ground_frac_rt(isd:ied,jsd:jed), source=0.0)
838
839 if (cs%calve_to_mask) then
840 allocate( cs%calve_mask(isd:ied,jsd:jed), source=0.0)
841 endif
842
843 allocate(cs%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0)
844 allocate(cs%Jac(1:4,isd:ied,jsd:jed), source=0.0)
845 do j=g%jsd,g%jed ; do i=g%isd,g%ied
846 call bilinear_shape_fn_grid(g, i, j, cs%Phi(:,:,i,j), cs%Jac(:,i,j))
847 enddo ; enddo
848
849 if (cs%GL_regularize) then
850 allocate(cs%Phisub(2,2,cs%n_sub_regularize,cs%n_sub_regularize,2,2), source=0.0)
851 call bilinear_shape_functions_subgrid(cs%Phisub, cs%n_sub_regularize)
852 endif
853
854 if ((trim(cs%ice_viscosity_compute) == "MODEL") .and. cs%visc_qps==1) then
855 !for calculating viscosity and 1 cell-centered quadrature point per cell
856 allocate(cs%PhiC(1:8,g%isc:g%iec,g%jsc:g%jec), source=0.0)
857 do j=g%jsc,g%jec ; do i=g%isc,g%iec
858 call bilinear_shape_fn_grid_1qp(g, i, j, cs%PhiC(:,i,j))
859 enddo ; enddo
860 endif
861
862 cs%elapsed_velocity_time = 0.0
863
864 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
865 endif
866
867 ! Take additional initialization steps, for example of dependent variables.
868 if (active_shelf_dynamics .and. .not.new_sim) then
869
870 call pass_var(cs%OD_av,g%domain, complete=.false.)
871 call pass_var(cs%ground_frac, g%domain, complete=.false.)
872 call pass_var(cs%AGlen_visc, g%domain, complete=.false.)
873 call pass_var(cs%bed_elev, g%domain, complete=.false.)
874 call pass_var(cs%C_basal_friction, g%domain, complete=.false.)
875 call pass_var(cs%h_bdry_val, g%domain, complete=.true.)
876 call pass_var(cs%ice_visc, g%domain)
877
878 call pass_vector(cs%u_bdry_val, cs%v_bdry_val, g%domain, to_all, bgrid_ne, complete=.false.)
879 call pass_vector(cs%u_face_mask_bdry, cs%v_face_mask_bdry, g%domain, to_all, bgrid_ne, complete=.true.)
880 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
881
882 ! This is unfortunately necessary (?); if grid is not symmetric the boundary values
883 ! of u and v are otherwise not set till the end of the first linear solve, and so
884 ! viscosity is not calculated correctly.
885 ! This has to occur after init_boundary_values or some of the arrays on the
886 ! right hand side have not been set up yet.
887 if (.not. g%symmetric) then
888 do j=g%jsd,g%jed ; do i=g%isd,g%ied
889 if ((i+g%idg_offset) == (g%domain%nihalo+1)) then
890 if (cs%u_face_mask(i-1,j) == 3) then
891 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
892 cs%u_shelf(i-1,j) = cs%u_bdry_val(i-1,j)
893 cs%v_shelf(i-1,j-1) = cs%v_bdry_val(i-1,j-1)
894 cs%v_shelf(i-1,j) = cs%v_bdry_val(i-1,j)
895 elseif (cs%u_face_mask(i-1,j) == 5) then
896 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
897 cs%u_shelf(i-1,j) = cs%u_bdry_val(i-1,j)
898 elseif (cs%u_face_mask(i-1,j) == 6) then
899 cs%v_shelf(i-1,j-1) = cs%v_bdry_val(i-1,j-1)
900 cs%v_shelf(i-1,j) = cs%v_bdry_val(i-1,j)
901 endif
902 endif
903 if ((j+g%jdg_offset) == (g%domain%njhalo+1)) then
904 if (cs%v_face_mask(i,j-1) == 3) then
905 cs%v_shelf(i-1,j-1) = cs%v_bdry_val(i-1,j-1)
906 cs%v_shelf(i,j-1) = cs%v_bdry_val(i,j-1)
907 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
908 cs%u_shelf(i,j-1) = cs%u_bdry_val(i,j-1)
909 elseif (cs%v_face_mask(i,j-1) == 5) then
910 cs%v_shelf(i-1,j-1) = cs%v_bdry_val(i-1,j-1)
911 cs%v_shelf(i,j-1) = cs%v_bdry_val(i,j-1)
912 elseif (cs%v_face_mask(i,j-1) == 6) then
913 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
914 cs%u_shelf(i,j-1) = cs%u_bdry_val(i,j-1)
915 endif
916 endif
917 enddo ; enddo
918 endif
919 call pass_vector(cs%u_shelf, cs%v_shelf, g%domain, to_all, bgrid_ne)
920 endif
921
922 if (active_shelf_dynamics) then
923 if (cs%first_dir_restart_IS > -1.0) then
924 cs%first_direction_IS = modulo(nint(cs%first_dir_restart_IS), 2)
925 else
926 cs%first_dir_restart_IS = real(modulo(cs%first_direction_IS, 2))
927 endif
928
929 ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file.
930 if (cs%calve_to_mask) then
931 call mom_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask")
932
933 call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".")
934 inputdir = slasher(inputdir)
935 call get_param(param_file, mdl, "CALVING_MASK_FILE", ic_file, &
936 "The file with a mask for where calving might occur.", &
937 default="ice_shelf_h.nc")
938 call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, &
939 "The variable to use in masking calving.", &
940 default="area_shelf_h")
941
942 filename = trim(inputdir)//trim(ic_file)
943 call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename)
944 if (.not.file_exists(filename, g%Domain)) call mom_error(fatal, &
945 " calving mask file: Unable to open "//trim(filename))
946
947 call mom_read_data(filename,trim(var_name),cs%calve_mask,g%Domain)
948 do j=g%jsc,g%jec ; do i=g%isc,g%iec
949 if (cs%calve_mask(i,j) > 0.0) cs%calve_mask(i,j) = 1.0
950 enddo ; enddo
951 call pass_var(cs%calve_mask,g%domain)
952 endif
953
954 ! initialize basal friction coefficients
955 if (new_sim) then
956 call initialize_ice_c_basal_friction(cs%C_basal_friction, g, us, param_file)
957 call pass_var(cs%C_basal_friction, g%domain, complete=.false.)
958
959 ! initialize ice-stiffness AGlen
960 call initialize_ice_aglen(cs%AGlen_visc, cs%ice_viscosity_compute, g, us, param_file)
961 call pass_var(cs%AGlen_visc, g%domain, complete=.false.)
962
963 !initialize boundary conditions
964 call initialize_ice_shelf_boundary_from_file(cs%u_face_mask_bdry, cs%v_face_mask_bdry, &
965 cs%u_bdry_val, cs%v_bdry_val, cs%umask, cs%vmask, cs%h_bdry_val, &
966 iss%hmask, iss%h_shelf, g, us, param_file )
967 call pass_var(iss%hmask, g%domain, complete=.false.)
968 call pass_var(cs%h_bdry_val, g%domain, complete=.true.)
969 call pass_vector(cs%u_bdry_val, cs%v_bdry_val, g%domain, to_all, bgrid_ne, complete=.false.)
970 call pass_vector(cs%u_face_mask_bdry, cs%v_face_mask_bdry, g%domain, to_all, bgrid_ne, complete=.false.)
971
972 !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file
973 call initialize_ice_flow_from_file(cs%bed_elev,cs%u_shelf, cs%v_shelf, cs%ground_frac, &
974 g, us, param_file)
975 call pass_vector(cs%u_shelf, cs%v_shelf, g%domain, to_all, bgrid_ne, complete=.true.)
976 call pass_var(cs%ground_frac, g%domain, complete=.false.)
977 call pass_var(cs%bed_elev, g%domain, complete=.true.)
978 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
979
980 do j=jsdq,jedq ; do i=isdq,iedq
981 if (cs%umask(i,j) == 3) then
982 cs%u_shelf(i,j) = cs%u_bdry_val(i,j)
983 elseif (cs%umask(i,j) == 0) then
984 cs%u_shelf(i,j) = 0
985 endif
986 if (cs%vmask(i,j) == 3) then
987 cs%v_shelf(i,j) = cs%v_bdry_val(i,j)
988 elseif (cs%vmask(i,j) == 0) then
989 cs%v_shelf(i,j) = 0
990 endif
991 enddo ; enddo
992 endif
993
994 ! Register diagnostics.
995 cs%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',cs%diag%axesB1, time, &
996 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*us%L_T_to_m_s)
997 cs%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',cs%diag%axesB1, time, &
998 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*us%L_T_to_m_s)
999 cs%id_shelf_speed = register_diag_field('ice_shelf_model','shelf_speed',cs%diag%axesB1, time, &
1000 'speed of of ice shelf', 'm yr-1', conversion=365.0*86400.0*us%L_T_to_m_s)
1001 cs%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',cs%diag%axesB1, time, &
1002 'x-driving stress of ice', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1003 cs%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',cs%diag%axesB1, time, &
1004 'y-driving stress of ice', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1005 cs%id_taud_shelf = register_diag_field('ice_shelf_model','taud_shelf',cs%diag%axesB1, time, &
1006 'magnitude of driving stress of ice', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1007 cs%id_sx_shelf = register_diag_field('ice_shelf_model', 'sx_shelf', cs%diag%axesT1, time, &
1008 'x-surface slope of ice', 'none')
1009 cs%id_sy_shelf = register_diag_field('ice_shelf_model', 'sy_shelf', cs%diag%axesT1, time, &
1010 'y-surface slope of ice', 'none')
1011 cs%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model', 'surf_slope_mag_shelf', cs%diag%axesT1, time, &
1012 'magnitude of surface slope of ice', 'none')
1013 cs%id_u_mask = register_diag_field('ice_shelf_model','u_mask',cs%diag%axesB1, time, &
1014 'mask for u-nodes', 'none')
1015 cs%id_v_mask = register_diag_field('ice_shelf_model','v_mask',cs%diag%axesB1, time, &
1016 'mask for v-nodes', 'none')
1017 cs%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',cs%diag%axesT1, time, &
1018 'fraction of cell that is grounded', 'none')
1019 cs%id_float_cond = register_diag_field('ice_shelf_model','float_cond',cs%diag%axesT1, time, &
1020 'sub-cell grounding cells', 'none')
1021 cs%id_col_thick = register_diag_field('ice_shelf_model','col_thick',cs%diag%axesT1, time, &
1022 'ocean column thickness passed to ice model', 'm', conversion=us%Z_to_m)
1023 cs%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',cs%diag%axesT1, time, &
1024 'vi-viscosity', 'Pa m s', conversion=us%RL2_T2_to_Pa*us%Z_to_m*us%T_to_s) !vertically integrated viscosity
1025 cs%id_taub = register_diag_field('ice_shelf_model','taub_beta',cs%diag%axesT1, time, &
1026 'basal traction coefficient, taub/|u|', units='MPa yr m-1', &
1027 conversion=1e-6*us%RLZ_T2_to_Pa/(365.0*86400.0*us%L_T_to_m_s))
1028 cs%id_OD_av = register_diag_field('ice_shelf_model','OD_av',cs%diag%axesT1, time, &
1029 'intermediate ocean column thickness passed to ice model', 'm', conversion=us%Z_to_m)
1030
1031 cs%id_duHdx = register_diag_field('ice_shelf_model','duHdx',cs%diag%axesT1, time, &
1032 'x-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*us%Z_to_m*us%s_to_T)
1033 cs%id_dvHdy = register_diag_field('ice_shelf_model','dvHdy',cs%diag%axesT1, time, &
1034 'y-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*us%Z_to_m*us%s_to_T)
1035 cs%id_fluxdiv = register_diag_field('ice_shelf_model','fluxdiv',cs%diag%axesT1, time, &
1036 'ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*us%Z_to_m*us%s_to_T)
1037 cs%id_strainrate_xx = register_diag_field('ice_shelf_model','strainrate_xx',cs%diag%axesT1, time, &
1038 'x-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*us%s_to_T)
1039 cs%id_strainrate_yy = register_diag_field('ice_shelf_model','strainrate_yy',cs%diag%axesT1, time, &
1040 'y-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*us%s_to_T)
1041 cs%id_strainrate_xy = register_diag_field('ice_shelf_model','strainrate_xy',cs%diag%axesT1, time, &
1042 'xy-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*us%s_to_T)
1043 cs%id_pstrainrate_1 = register_diag_field('ice_shelf_model','pstrainrate_1',cs%diag%axesT1, time, &
1044 'max principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*us%s_to_T)
1045 cs%id_pstrainrate_2 = register_diag_field('ice_shelf_model','pstrainrate_2',cs%diag%axesT1, time, &
1046 'min principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*us%s_to_T)
1047 cs%id_devstress_xx = register_diag_field('ice_shelf_model','devstress_xx',cs%diag%axesT1, time, &
1048 'x-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1049 cs%id_devstress_yy = register_diag_field('ice_shelf_model','devstress_yy',cs%diag%axesT1, time, &
1050 'y-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1051 cs%id_devstress_xy = register_diag_field('ice_shelf_model','devstress_xy',cs%diag%axesT1, time, &
1052 'xy-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1053 cs%id_pdevstress_1 = register_diag_field('ice_shelf_model','pdevstress_1',cs%diag%axesT1, time, &
1054 'max principal horizontal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1055 cs%id_pdevstress_2 = register_diag_field('ice_shelf_model','pdevstress_2',cs%diag%axesT1, time, &
1056 'min principal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*us%RLZ_T2_to_Pa)
1057
1058 !Update these variables so that they are nonzero in case
1059 !IS_dynamics_post_data is called before update_ice_shelf
1060 if (cs%id_taudx_shelf>0 .or. cs%id_taudy_shelf>0) &
1061 call calc_shelf_driving_stress(cs, iss, g, us, cs%taudx_shelf, cs%taudy_shelf, cs%OD_av)
1062 if (cs%id_visc_shelf>0) &
1063 call calc_shelf_visc(cs, iss, g, us, cs%u_shelf, cs%v_shelf)
1064 endif
1065
1066 if (new_sim) then
1067 call update_od_ffrac_uncoupled(cs, g, iss%h_shelf(:,:))
1068 endif
1069
1070end subroutine initialize_ice_shelf_dyn
1071
1072
1073subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time)
1074 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
1075 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
1076 !! the ice-shelf state
1077 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
1078 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
1079 type(time_type), intent(in) :: Time !< The current model time
1080
1081 integer :: i, j, iters, isd, ied, jsd, jed
1082 real :: OD ! Depth of open water below the ice shelf [Z ~> m]
1083 type(time_type) :: dummy_time
1084!
1085 dummy_time = set_time(0,0)
1086 isd=g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
1087
1088 do j=jsd,jed
1089 do i=isd,ied
1090 od = cs%bed_elev(i,j) - cs%rhoi_rhow * max(iss%h_shelf(i,j),cs%min_h_shelf)
1091 if (od >= 0) then
1092 ! ice thickness does not take up whole ocean column -> floating
1093 cs%OD_av(i,j) = od
1094 cs%ground_frac(i,j) = 0.
1095 else
1096 cs%OD_av(i,j) = 0.
1097 cs%ground_frac(i,j) = 1.
1098 endif
1099 enddo
1100 enddo
1101
1102 call ice_shelf_solve_outer(cs, iss, g, us, cs%u_shelf, cs%v_shelf,cs%taudx_shelf,cs%taudy_shelf, iters, time)
1103end subroutine initialize_diagnostic_fields
1104
1105!> This function returns the global maximum advective timestep that can be taken based on the current
1106!! ice velocities. Because it involves finding a global minimum, it can be surprisingly expensive.
1107function ice_time_step_cfl(CS, ISS, G)
1108 type(ice_shelf_dyn_cs), intent(inout) :: cs !< The ice shelf dynamics control structure
1109 type(ice_shelf_state), intent(inout) :: iss !< A structure with elements that describe
1110 !! the ice-shelf state
1111 type(ocean_grid_type), intent(inout) :: g !< The grid structure used by the ice shelf.
1112 real :: ice_time_step_cfl !< The maximum permitted timestep based on the ice velocities [T ~> s].
1113
1114 real :: dt_local, min_dt ! These should be the minimum stable timesteps at a CFL of 1 [T ~> s]
1115 real :: min_vel ! A minimal velocity for estimating a timestep [L T-1 ~> m s-1]
1116 integer :: i, j
1117
1118 min_dt = 5.0e17*g%US%s_to_T ! The starting maximum is roughly the lifetime of the universe.
1119 min_vel = (1.0e-12/(365.0*86400.0)) * g%US%m_s_to_L_T
1120 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
1121 dt_local = 2.0*g%areaT(i,j) / &
1122 (((g%dyCu(i,j) * max(abs(cs%u_shelf(i,j) + cs%u_shelf(i,j-1)), min_vel)) + &
1123 (g%dyCu(i-1,j)* max(abs(cs%u_shelf(i-1,j)+ cs%u_shelf(i-1,j-1)), min_vel))) + &
1124 ((g%dxCv(i,j) * max(abs(cs%v_shelf(i,j) + cs%v_shelf(i-1,j)), min_vel)) + &
1125 (g%dxCv(i,j-1)* max(abs(cs%v_shelf(i,j-1)+ cs%v_shelf(i-1,j-1)), min_vel))))
1126
1127 min_dt = min(min_dt, dt_local)
1128 endif ; enddo ; enddo ! i- and j- loops
1129
1130 call min_across_pes(min_dt)
1131
1132 ice_time_step_cfl = cs%CFL_factor * min_dt
1133
1134end function ice_time_step_cfl
1135
1136!> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the
1137!! ice shelf dynamics.
1138subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, calve_ice_shelf_bergs, &
1139 ocean_mass, coupled_grounding, must_update_vel)
1140 type(ice_shelf_dyn_cs), intent(inout) :: cs !< The ice shelf dynamics control structure
1141 type(ice_shelf_state), intent(inout) :: iss !< A structure with elements that describe
1142 !! the ice-shelf state
1143 type(ocean_grid_type), intent(inout) :: g !< The grid structure used by the ice shelf.
1144 type(unit_scale_type), intent(in) :: us !< A structure containing unit conversion factors
1145 real, intent(in) :: time_step !< time step [T ~> s]
1146 type(time_type), intent(in) :: time !< The current model time
1147 logical, intent(in) :: calve_ice_shelf_bergs !< To convert ice flux through front
1148 !! to bergs
1149 real, dimension(SZDI_(G),SZDJ_(G)), &
1150 optional, intent(in) :: ocean_mass !< If present this is the mass per unit area
1151 !! of the ocean [R Z ~> kg m-2].
1152 logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is
1153 !! determined by coupled ice-ocean dynamics
1154 logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true.
1155 integer :: iters
1156 logical :: update_ice_vel, coupled_gl
1157
1158 update_ice_vel = .false.
1159 if (present(must_update_vel)) update_ice_vel = must_update_vel
1160
1161 coupled_gl = .false.
1162 if (present(ocean_mass) .and. present(coupled_grounding)) coupled_gl = coupled_grounding
1163!
1164 if (cs%advect_shelf) then
1165 call ice_shelf_advect(cs, iss, g, time_step, time, calve_ice_shelf_bergs)
1166 if (cs%alternate_first_direction_IS) then
1167 cs%first_direction_IS = modulo(cs%first_direction_IS+1,2)
1168 cs%first_dir_restart_IS = real(cs%first_direction_IS)
1169 endif
1170 endif
1171 cs%elapsed_velocity_time = cs%elapsed_velocity_time + time_step
1172 if (cs%elapsed_velocity_time >= cs%velocity_update_time_step) update_ice_vel = .true.
1173
1174 if (coupled_gl) then
1175 call update_od_ffrac(cs, g, us, ocean_mass, update_ice_vel)
1176 elseif (update_ice_vel) then
1177 call update_od_ffrac_uncoupled(cs, g, iss%h_shelf(:,:))
1178 cs%GL_couple=.false.
1179 endif
1180
1181 if (update_ice_vel) then
1182 call ice_shelf_solve_outer(cs, iss, g, us, cs%u_shelf, cs%v_shelf,cs%taudx_shelf,cs%taudy_shelf, iters, time)
1183 cs%elapsed_velocity_time = 0.0
1184 endif
1185
1186! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time)
1187
1188end subroutine update_ice_shelf
1189
1190subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere)
1191 type(ice_shelf_dyn_cs), intent(in) :: cs !< The ice shelf dynamics control structure
1192 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
1193 type(ice_shelf_state), intent(in) :: iss !< A structure with elements that describe
1194 !! the ice-shelf state
1195 real, intent(out) :: vaf !< area integrated volume above floatation [Z L2 ~> m3]
1196 integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets
1197 integer :: is_id ! local copy of hemisphere
1198 real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [Z L2 ~> m3]
1199 integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated
1200 integer :: is, ie, js, je, i, j
1201
1202 if (cs%GL_couple) &
1203 call mom_error(fatal, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..")
1204
1205 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
1206
1207 if (present(hemisphere)) then
1208 is_id=hemisphere
1209 else
1210 is_id=-1
1211 endif
1212
1213 mask(:,:)=0
1214 if (is_id==0) then !Antarctica (S. Hemisphere) only
1215 do j = js,je ; do i = is,ie
1216 if (iss%hmask(i,j)>0 .and. g%geoLatT(i,j)<=0.0) mask(i,j)=1
1217 enddo ; enddo
1218 elseif (is_id==1) then !Greenland (N. Hemisphere) only
1219 do j = js,je ; do i = is,ie
1220 if (iss%hmask(i,j)>0 .and. g%geoLatT(i,j)>0.0) mask(i,j)=1
1221 enddo ; enddo
1222 else !All ice sheets
1223 mask(is:ie,js:je)=iss%hmask(is:ie,js:je)
1224 endif
1225
1226 vaf_cell(:,:)=0.0
1227 do j = js,je ; do i = is,ie
1228 if (mask(i,j)>0) then
1229 if (cs%bed_elev(i,j) <= 0) then
1230 !grounded above sea level
1231 vaf_cell(i,j) = iss%h_shelf(i,j) * iss%area_shelf_h(i,j)
1232 else
1233 !grounded if vaf_cell(i,j) > 0
1234 vaf_cell(i,j) = max(iss%h_shelf(i,j) - cs%rhow_rhoi * cs%bed_elev(i,j), 0.0) * iss%area_shelf_h(i,j)
1235 endif
1236 endif
1237 enddo ; enddo
1238
1239 vaf = reproducing_sum(vaf_cell, unscale=g%US%Z_to_m*g%US%L_to_m**2)
1240end subroutine volume_above_floatation
1241
1242!> multiplies a variable with the ice sheet grounding fraction
1243subroutine masked_var_grounded(G,CS,var,varout)
1244 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
1245 type(ice_shelf_dyn_cs), intent(in) :: cs !< The ice shelf dynamics control structure
1246 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< variable in
1247 real, dimension(SZI_(G),SZJ_(G)), intent(out) :: varout !<variable out
1248 integer :: i, j
1249 do j = g%jsc,g%jec ; do i = g%isc,g%iec
1250 varout(i,j) = var(i,j) * cs%ground_frac(i,j)
1251 enddo ; enddo
1252end subroutine masked_var_grounded
1253
1254!> Ice shelf dynamics post_data calls
1255subroutine is_dynamics_post_data(time_step, Time, CS, ISS, G)
1256 real :: time_step !< Length of time for post data averaging [T ~> s].
1257 type(time_type), intent(in) :: time !< The current model time
1258 type(ice_shelf_dyn_cs), intent(inout) :: cs !< The ice shelf dynamics control structure
1259 type(ice_shelf_state), intent(inout) :: iss !< A structure with elements that describe
1260 !! the ice-shelf state
1261 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
1262 real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y, taud ! area-averaged driving stress [R L2 T-2 ~> Pa]
1263 real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged vertically integrated ice viscosity
1264 !! [R L2 Z T-1 ~> Pa s m]
1265 real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! taub_beta, the basal traction coefficient taub/|u|,
1266 !! [R Z T-1 ~> Pa s m-1]
1267 real, dimension(SZDI_(G),SZDJ_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim]
1268 real, dimension(SZDIB_(G),SZDJB_(G)) :: ice_speed ! ice sheet flow speed [L T-1 ~> m s-1]
1269
1270 integer :: i, j
1271
1272 call enable_averages(time_step, time, cs%diag)
1273 if (cs%id_col_thick > 0) call post_data(cs%id_col_thick, cs%OD_av, cs%diag)
1274 if (cs%id_u_shelf > 0) call post_data(cs%id_u_shelf, cs%u_shelf, cs%diag)
1275 if (cs%id_v_shelf > 0) call post_data(cs%id_v_shelf, cs%v_shelf, cs%diag)
1276 if (cs%id_shelf_speed > 0) then
1277 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1278 ice_speed(i,j) = sqrt((cs%u_shelf(i,j)**2) + (cs%v_shelf(i,j)**2))
1279 enddo ; enddo
1280 call post_data(cs%id_shelf_speed, ice_speed, cs%diag)
1281 endif
1282! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag)
1283 if (cs%id_taudx_shelf > 0) then
1284 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1285 taud_x(i,j) = cs%taudx_shelf(i,j)*g%IareaBu(i,j)
1286 enddo ; enddo
1287 call post_data(cs%id_taudx_shelf, taud_x, cs%diag)
1288 endif
1289 if (cs%id_taudy_shelf > 0) then
1290 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1291 taud_y(i,j) = cs%taudy_shelf(i,j)*g%IareaBu(i,j)
1292 enddo ; enddo
1293 call post_data(cs%id_taudy_shelf, taud_y, cs%diag)
1294 endif
1295 if (cs%id_taud_shelf > 0) then
1296 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1297 taud(i,j) = sqrt((cs%taudx_shelf(i,j)**2)+(cs%taudy_shelf(i,j)**2))*g%IareaBu(i,j)
1298 enddo ; enddo
1299 call post_data(cs%id_taud_shelf, taud, cs%diag)
1300 endif
1301 if (cs%id_sx_shelf > 0) call post_data(cs%id_sx_shelf, cs%sx_shelf, cs%diag)
1302 if (cs%id_sy_shelf > 0) call post_data(cs%id_sy_shelf, cs%sy_shelf, cs%diag)
1303 if (cs%id_surf_slope_mag_shelf > 0) then
1304 do j=g%jsc,g%jec ; do i=g%isc,g%iec
1305 surf_slope(i,j) = sqrt((cs%sx_shelf(i,j)**2)+(cs%sy_shelf(i,j)**2))
1306 enddo ; enddo
1307 call post_data(cs%id_surf_slope_mag_shelf, surf_slope, cs%diag)
1308 endif
1309 if (cs%id_ground_frac > 0) call post_data(cs%id_ground_frac, cs%ground_frac, cs%diag)
1310 if (cs%id_float_cond > 0) call post_data(cs%id_float_cond, cs%float_cond, cs%diag)
1311 if (cs%id_OD_av >0) call post_data(cs%id_OD_av, cs%OD_av,cs%diag)
1312 if (cs%id_visc_shelf > 0) then
1313 call ice_visc_diag(cs,g,ice_visc)
1314 call post_data(cs%id_visc_shelf, ice_visc, cs%diag)
1315 endif
1316 if (cs%id_taub > 0) then
1317 call calc_shelf_taub(cs, iss, g, basal_tr)
1318 call post_data(cs%id_taub, basal_tr, cs%diag)
1319 endif
1320 if (cs%id_u_mask > 0) call post_data(cs%id_u_mask, cs%umask, cs%diag)
1321 if (cs%id_v_mask > 0) call post_data(cs%id_v_mask, cs%vmask, cs%diag)
1322 if (cs%id_ufb_mask > 0) call post_data(cs%id_ufb_mask, cs%u_face_mask_bdry, cs%diag)
1323 if (cs%id_vfb_mask > 0) call post_data(cs%id_vfb_mask, cs%v_face_mask_bdry, cs%diag)
1324! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag)
1325
1326 if (cs%id_duHdx > 0 .or. cs%id_dvHdy > 0 .or. cs%id_fluxdiv > 0 .or. &
1327 cs%id_devstress_xx > 0 .or. cs%id_devstress_yy > 0 .or. cs%id_devstress_xy > 0 .or. &
1328 cs%id_strainrate_xx > 0 .or. cs%id_strainrate_yy > 0 .or. cs%id_strainrate_xy > 0 .or. &
1329 cs%id_pdevstress_1 > 0 .or. cs%id_pdevstress_2 > 0 .or. &
1330 cs%id_pstrainrate_1 > 0 .or. cs%id_pstrainrate_2 > 0) then
1331 call is_dynamics_post_data_2(cs, iss, g)
1332 endif
1333
1334 call disable_averaging(cs%diag)
1335end subroutine is_dynamics_post_data
1336
1337!> Calculate cell-centered, area-averaged, vertically integrated ice viscosity for diagnostics
1338subroutine ice_visc_diag(CS,G,ice_visc)
1339 type(ice_shelf_dyn_cs), intent(in) :: CS !< The ice shelf dynamics control structure
1340 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
1341 real, dimension(SZDI_(G),SZDJ_(G)), intent(out) :: ice_visc !< area-averaged vertically integrated ice viscosity
1342 !! [R L2 Z T-1 ~> Pa s m]
1343 integer :: i, j
1344
1345 ice_visc(:,:)=0.0
1346 if (cs%visc_qps==4) then
1347 do j=g%jsc,g%jec ; do i=g%isc,g%iec
1348 ice_visc(i,j) = (0.25 * g%IareaT(i,j)) * &
1349 ((cs%ice_visc(i,j,1) + cs%ice_visc(i,j,4)) + (cs%ice_visc(i,j,2) + cs%ice_visc(i,j,3)))
1350 enddo ; enddo
1351 else
1352 do j=g%jsc,g%jec ; do i=g%isc,g%iec
1353 ice_visc(i,j) = cs%ice_visc(i,j,1)*g%IareaT(i,j)
1354 enddo ; enddo
1355 endif
1356end subroutine ice_visc_diag
1357
1358!> Writes the total ice shelf kinetic energy and mass to an ascii file
1359subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step)
1360 type(ice_shelf_dyn_cs), intent(inout) :: cs !< The ice shelf dynamics control structure
1361 type(ocean_grid_type), intent(inout) :: g !< The grid structure used by the ice shelf.
1362 type(unit_scale_type), intent(in) :: us !< A structure containing unit conversion factors
1363 real, dimension(SZDI_(G),SZDJ_(G)), &
1364 intent(in) :: mass !< The mass per unit area of the ice shelf
1365 !! or sheet [R Z ~> kg m-2]
1366 real, dimension(SZDI_(G),SZDJ_(G)), &
1367 intent(in) :: area !< The ice shelf or ice sheet area [L2 ~> m2]
1368 type(time_type), intent(in) :: day !< The current model time.
1369 type(time_type), optional, intent(in) :: time_step !< The current time step
1370 ! Local variables
1371 type(time_type) :: dt ! A time_type version of the timestep.
1372 real, dimension(SZDI_(G),SZDJ_(G)) :: tmp1 ! A temporary array used in reproducing sums [various]
1373 real :: ke_tot ! The total kinetic energy [R Z L4 T-2 ~> J]
1374 real :: mass_tot ! The total mass [R Z L2 ~> kg]
1375 integer :: is, ie, js, je, isr, ier, jsr, jer, i, j
1376 character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str
1377 integer :: start_of_day, num_days
1378 real :: reday ! Time in units given by CS%Timeunit, but often [days]
1379 logical :: is_open
1380 ! True if CS%fileenergy_ascii is open
1381
1382 ! write_energy_time is the next integral multiple of energysavedays.
1383 if (present(time_step)) then
1384 dt = time_step
1385 else
1386 dt = set_time(seconds=2)
1387 endif
1388
1389 !CS%prev_IS_energy_calls tracks the ice sheet step, which is outputted in the energy file.
1390 if (cs%prev_IS_energy_calls == 0) then
1391 if (cs%energysave_geometric) then
1392 if (cs%energysavedays_geometric < cs%energysavedays) then
1393 cs%write_energy_time = day + cs%energysavedays_geometric
1394 cs%geometric_end_time = cs%Start_time + cs%energysavedays * &
1395 (1 + (day - cs%Start_time) / cs%energysavedays)
1396 else
1397 cs%write_energy_time = cs%Start_time + cs%energysavedays * &
1398 (1 + (day - cs%Start_time) / cs%energysavedays)
1399 endif
1400 else
1401 cs%write_energy_time = cs%Start_time + cs%energysavedays * &
1402 (1 + (day - cs%Start_time) / cs%energysavedays)
1403 endif
1404 elseif (day + (dt/2) <= cs%write_energy_time) then
1405 cs%prev_IS_energy_calls = cs%prev_IS_energy_calls + 1
1406 return ! Do not write this step
1407 else ! Determine the next write time before proceeding
1408 if (cs%energysave_geometric) then
1409 if (cs%write_energy_time + cs%energysavedays_geometric >= &
1410 cs%geometric_end_time) then
1411 cs%write_energy_time = cs%geometric_end_time
1412 cs%energysave_geometric = .false. ! stop geometric progression
1413 else
1414 cs%write_energy_time = cs%write_energy_time + cs%energysavedays_geometric
1415 endif
1416 cs%energysavedays_geometric = cs%energysavedays_geometric*2
1417 else
1418 cs%write_energy_time = cs%write_energy_time + cs%energysavedays
1419 endif
1420 endif
1421
1422 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
1423 isr = is - (g%isd-1) ; ier = ie - (g%isd-1) ; jsr = js - (g%jsd-1) ; jer = je - (g%jsd-1)
1424
1425 !calculate KE using cell-centered ice shelf velocity
1426 tmp1(:,:) = 0.0
1427 do j=js,je ; do i=is,ie
1428 tmp1(i,j) = 0.03125 * (mass(i,j) * area(i,j)) * &
1429 ((((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) + &
1430 (((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))
1431 enddo ; enddo
1432
1433 ke_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=(us%RZL2_to_kg*us%L_T_to_m_s**2))
1434
1435 !calculate mass
1436 tmp1(:,:) = 0.0
1437 do j=js,je ; do i=is,ie
1438 tmp1(i,j) = mass(i,j) * area(i,j)
1439 enddo ; enddo
1440
1441 mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=us%RZL2_to_kg)
1442
1443 if (is_root_pe()) then ! Only the root PE actually writes anything.
1444 if (day > cs%Start_time) then
1445 is_open = .false.
1446 if (cs%IS_fileenergy_ascii /= -1) &
1447 inquire(unit=cs%IS_fileenergy_ascii, opened=is_open)
1448 if (.not. is_open) &
1449 call open_ascii_file(cs%IS_fileenergy_ascii, trim(cs%IS_energyfile), action=append_file)
1450 else
1451 call open_ascii_file(cs%IS_fileenergy_ascii, trim(cs%IS_energyfile), action=writeonly_file)
1452 if (abs(cs%timeunit - 86400.0) < 1.0) then
1453 write(cs%IS_fileenergy_ascii,'(" Step,",7x,"Day,",8x,"Energy/Mass,",13x,"Total Mass")')
1454 write(cs%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")')
1455 else
1456 if ((cs%timeunit >= 0.99) .and. (cs%timeunit < 1.01)) then
1457 time_units = " [seconds] "
1458 elseif ((cs%timeunit >= 3599.0) .and. (cs%timeunit < 3601.0)) then
1459 time_units = " [hours] "
1460 elseif ((cs%timeunit >= 86399.0) .and. (cs%timeunit < 86401.0)) then
1461 time_units = " [days] "
1462 elseif ((cs%timeunit >= 3.0e7) .and. (cs%timeunit < 3.2e7)) then
1463 time_units = " [years] "
1464 else
1465 write(time_units,'(9x,"[",es8.2," s] ")') cs%timeunit
1466 endif
1467
1468 write(cs%IS_fileenergy_ascii,'(" Step,",7x,"Time,",7x,"Energy/Mass,",13x,"Total Mass")')
1469 write(cs%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units
1470 endif
1471 endif
1472
1473 call get_time(day, start_of_day, num_days)
1474
1475 if (abs(cs%timeunit - 86400.0) < 1.0) then
1476 reday = real(num_days)+ (real(start_of_day)/86400.0)
1477 else
1478 reday = real(num_days)*(86400.0/cs%timeunit) + real(start_of_day)/abs(cs%timeunit)
1479 endif
1480
1481 if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday
1482 elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday
1483 else ; write(day_str, '(ES15.9)') reday ; endif
1484
1485 if (cs%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') cs%prev_IS_energy_calls
1486 else ; write(n_str, '(I0)') cs%prev_IS_energy_calls ; endif
1487
1488 write(cs%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') &
1489 trim(n_str), trim(day_str), us%L_T_to_m_s**2*ke_tot/mass_tot, us%RZL2_to_kg*mass_tot
1490 endif
1491
1492 cs%prev_IS_energy_calls = cs%prev_IS_energy_calls + 1
1493end subroutine write_ice_shelf_energy
1494
1495!> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once.
1496!! Additionally, it will update the volume of ice in partially-filled cells, and update
1497!! hmask accordingly
1498subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs)
1499 type(ice_shelf_dyn_cs), intent(inout) :: CS !< The ice shelf dynamics control structure
1500 type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe
1501 !! the ice-shelf state
1502 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
1503 real, intent(in) :: time_step !< time step [T ~> s]
1504 type(time_type), intent(in) :: Time !< The current model time
1505 logical, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a
1506 !! static ice shelf, so that it can be converted into icebergs
1507
1508! 3/8/11 DNG
1509!
1510! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once.
1511! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update
1512! hmask accordingly
1513!
1514! The flux overflows are included here. That is because they will be used to advect 3D scalars
1515! into partial cells
1516
1517 real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_flux1, h_after_flux2 ! Ice thicknesses [Z ~> m].
1518 real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3]
1519 real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3]
1520 type(loop_bounds_type) :: LB
1521 integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil
1522
1523 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
1524 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
1525
1526 uh_ice(:,:) = 0.0
1527 vh_ice(:,:) = 0.0
1528
1529 h_after_flux1(:,:) = 0.0
1530 h_after_flux2(:,:) = 0.0
1531 ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called")
1532
1533 do j=jsd,jed ; do i=isd,ied ; if (cs%h_bdry_val(i,j) /= 0.0) then
1534 iss%h_shelf(i,j) = cs%h_bdry_val(i,j)
1535 endif ; enddo ; enddo
1536
1537 stencil = 2
1538 if (modulo(cs%first_direction_IS,2)==0) then
1539 !x first
1540 lb%ish = g%isc ; lb%ieh = g%iec ; lb%jsh = g%jsc-stencil ; lb%jeh = g%jec+stencil
1541 if (lb%jsh < jsd) call mom_error(fatal, &
1542 "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.")
1543 call ice_shelf_advect_thickness_x(cs, g, lb, time_step, iss%hmask, iss%h_shelf, h_after_flux1, uh_ice)
1544 call pass_var(h_after_flux1, g%domain)
1545 lb%ish = g%isc ; lb%ieh = g%iec ; lb%jsh = g%jsc ; lb%jeh = g%jec
1546 call ice_shelf_advect_thickness_y(cs, g, lb, time_step, iss%hmask, h_after_flux1, h_after_flux2, vh_ice)
1547 else
1548 ! y first
1549 lb%ish = g%isc-stencil ; lb%ieh = g%iec+stencil ; lb%jsh = g%jsc ; lb%jeh = g%jec
1550 if (lb%ish < isd) call mom_error(fatal, &
1551 "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.")
1552 call ice_shelf_advect_thickness_y(cs, g, lb, time_step, iss%hmask, iss%h_shelf, h_after_flux1, vh_ice)
1553 call pass_var(h_after_flux1, g%domain)
1554 lb%ish = g%isc ; lb%ieh = g%iec ; lb%jsh = g%jsc ; lb%jeh = g%jec
1555 call ice_shelf_advect_thickness_x(cs, g, lb, time_step, iss%hmask, h_after_flux1, h_after_flux2, uh_ice)
1556 endif
1557 call pass_var(h_after_flux2, g%domain)
1558
1559 do j=jsd,jed
1560 do i=isd,ied
1561 if (iss%hmask(i,j) == 1) iss%h_shelf(i,j) = h_after_flux2(i,j)
1562 enddo
1563 enddo
1564
1565 if (cs%moving_shelf_front) then
1566 call shelf_advance_front(cs, iss, g, iss%hmask, uh_ice, vh_ice)
1567 if (cs%min_thickness_simple_calve > 0.0) then
1568 call ice_shelf_min_thickness_calve(g, iss%h_shelf, iss%area_shelf_h, iss%hmask, &
1569 cs%min_thickness_simple_calve)
1570 endif
1571 if (cs%calve_to_mask) then
1572 call calve_to_mask(g, iss%h_shelf, iss%area_shelf_h, iss%hmask, cs%calve_mask)
1573 endif
1574 elseif (calve_ice_shelf_bergs) then
1575 !advect the front to create partially-filled cells
1576 call shelf_advance_front(cs, iss, g, iss%hmask, uh_ice, vh_ice)
1577 !add mass of the partially-filled cells to calving field, which is used to initialize icebergs
1578 !Then, remove the partially-filled cells from the ice shelf
1579 iss%calving(:,:) = 0.0
1580 iss%calving_hflx(:,:) = 0.0
1581 do j=jsc,jec ; do i=isc,iec
1582 if (iss%hmask(i,j)==2) then
1583 iss%calving(i,j) = (iss%h_shelf(i,j) * cs%density_ice) * &
1584 (iss%area_shelf_h(i,j) * g%IareaT(i,j)) / time_step
1585 iss%calving_hflx(i,j) = (cs%Cp_ice * cs%t_shelf(i,j)) * &
1586 ((iss%h_shelf(i,j) * cs%density_ice) * &
1587 (iss%area_shelf_h(i,j) * g%IareaT(i,j)))
1588 iss%h_shelf(i,j) = 0.0 ; iss%area_shelf_h(i,j) = 0.0 ; iss%hmask(i,j) = 0.0
1589 endif
1590 enddo ; enddo
1591 endif
1592
1593 do j=jsc,jec ; do i=isc,iec
1594 iss%mass_shelf(i,j) = iss%h_shelf(i,j) * cs%density_ice
1595 enddo ; enddo
1596
1597 call pass_var(iss%mass_shelf, g%domain, complete=.false.)
1598 call pass_var(iss%h_shelf, g%domain, complete=.false.)
1599 call pass_var(iss%area_shelf_h, g%domain, complete=.false.)
1600 call pass_var(iss%hmask, g%domain, complete=.true.)
1601
1602 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
1603
1604end subroutine ice_shelf_advect
1605
1606!>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity
1607!subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time)
1608subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time)
1609 type(ice_shelf_dyn_cs), intent(inout) :: CS !< The ice shelf dynamics control structure
1610 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
1611 !! the ice-shelf state
1612 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
1613 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
1614 real, dimension(SZDIB_(G),SZDJB_(G)), &
1615 intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1]
1616 real, dimension(SZDIB_(G),SZDJB_(G)), &
1617 intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1]
1618 integer, intent(out) :: iters !< The number of iterations used in the solver.
1619 type(time_type), intent(in) :: Time !< The current model time
1620
1621 real, dimension(SZDIB_(G),SZDJB_(G)), &
1622 intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2]
1623 real, dimension(SZDIB_(G),SZDJB_(G)), &
1624 intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2]
1625 !real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2]
1626 !real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2]
1627 real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2]
1628 real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1]
1629 real, dimension(SZDIB_(G),SZDJB_(G)) :: u_pre_newton, v_pre_newton ! Velocities saved at the
1630 ! Picard-to-Newton switch, restored if Newton
1631 ! diverges [L T-1 ~> m s-1]
1632 real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m].
1633 real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, indicates cells containing
1634 ! the grounding line (float_cond=1) or not (float_cond=0)
1635 real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Velocities used for convergence [L2 T-2 ~> m2 s-2]
1636 logical :: converged ! Indicates nonlinear convergence
1637 logical :: calc_Au_for_convergence ! Used for convergence criteria than need a CG_action
1638 character(len=160) :: mesg ! The text of an error message
1639 integer :: conv_flag, i, j, k, l, iter, nodefloat
1640 integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed
1641 integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec
1642 real :: err_max, err_tempu, err_tempv, err_init ! Errors in [R L3 Z T-2 ~> kg m s-2] or [L T-1 ~> m s-1]
1643 real :: norm_tau, err_rr ! Errors in [R L3 Z T-2 ~> kg m s-2] for relative residual
1644 real :: ew_resid = 0.0 ! L2 norm of stress residual ||A(u)u - tau|| for Eisenstat-Walker [kg m s-2]
1645 real :: ew_prev_resid = 0.0 ! Previous ew_resid; 0.0 flags first Newton call [kg m s-2]
1646 real :: ew_eta = 0.0 ! Current EW inner tolerance [nondim]
1647 real :: ew_eta_prev = 0.0 ! Previous EW inner tolerance for Chacon 2008 sharp-decrease safeguard [nondim]
1648 real :: ew_stol ! Temporary safeguard tolerance [nondim]
1649 real :: max_vel ! The maximum velocity magnitude [L T-1 ~> m s-1]
1650 real :: tempu, tempv ! Temporary variables with velocity magnitudes [L T-1 ~> m s-1]
1651 real :: Norm, PrevNorm ! Velocities used to assess convergence [L T-1 ~> m s-1]
1652 real :: newton_after_tol_loc ! Working Picard-to-Newton switch threshold for this solve,
1653 ! reduced tenfold on each divergence rescue [nondim]
1654 real :: err_newton_enter ! Nonlinear residual at the Picard-to-Newton switch, the
1655 ! reference for the divergence test [R L3 Z T-2 ~> kg m s-2] or [L T-1 ~> m s-1]
1656 real :: Norm_newton_enter ! Norm saved at the switch for restore (err mode 3) [L T-1 ~> m s-1]
1657 logical :: rescue_enabled ! Newton divergence rescue is configured and applicable
1658 logical :: newton_armed ! Pre-Newton state is saved; divergence rescue available
1659 logical :: diverging ! The current Newton residual triggers a rescue
1660 integer :: n_rescue ! Number of divergence rescues performed in this solve
1661 integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1.
1662 integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec
1663
1664 isdq = g%IsdB ; iedq = g%IedB ; jsdq = g%JsdB ; jedq = g%JedB
1665 iscq = g%IscB ; iecq = g%IecB ; jscq = g%JscB ; jecq = g%JecB
1666 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
1667 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
1668
1669 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1.
1670 ! Includes the edge of the tile is at the western/southern bdry (if symmetric)
1671 if (cs%nonlin_solve_err_mode >= 3 .or. cs%ssa_add_rel_resid) then
1672 if ((isc+g%idg_offset==g%isg) .and. (.not. cs%reentrant_x)) then
1673 is_sum = iscq + (1-isdq) ; iscq_sv = iscq
1674 else
1675 is_sum = isc + (1-isdq) ; iscq_sv = isc
1676 endif
1677 if ((jsc+g%jdg_offset==g%jsg) .and. (.not. cs%reentrant_y)) then
1678 js_sum = jscq + (1-jsdq) ; jscq_sv = jscq
1679 else
1680 js_sum = jsc + (1-jsdq) ; jscq_sv = jsc
1681 endif
1682 ie_sum = iecq + (1-isdq) ; je_sum = jecq + (1-jsdq)
1683 endif
1684
1685 taudx(:,:) = 0.0 ; taudy(:,:) = 0.0
1686 au(:,:) = 0.0 ; av(:,:) = 0.0
1687
1688 ! need to make these conditional on GL interpolation
1689 cs%float_cond(:,:) = 0.0 ; h_node(:,:) = 0.0
1690 !CS%ground_frac(:,:) = 0.0
1691
1692 if (.not. cs%GL_couple) then
1693 do j=g%jsc,g%jec ; do i=g%isc,g%iec
1694 if (cs%rhoi_rhow * max(iss%h_shelf(i,j),cs%min_h_shelf) - cs%bed_elev(i,j) > 0) then
1695 cs%ground_frac(i,j) = 1.0
1696 cs%OD_av(i,j) =0.0
1697 endif
1698 enddo ; enddo
1699 endif
1700
1701 ! Warning: This turns off Picard entirely and may not converge.
1702 if (cs%newton_after_tolerance<0.0) cs%doing_newton=.true.
1703
1704 ! Calculate RHS
1705 call calc_shelf_driving_stress(cs, iss, g, us, taudx, taudy, cs%OD_av)
1706 call pass_vector(taudx, taudy, g%domain, to_all, bgrid_ne)
1707
1708 ! This is to determine which cells contain the grounding line, the criterion being that the cell
1709 ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by
1710 ! assuming topography is cellwise constant and H is bilinear in a cell; floating where
1711 ! rho_i/rho_w * H_node - D is negative
1712 ! need to make this conditional on GL interp
1713 if (cs%GL_regularize) then
1714
1715 call interpolate_h_to_b(g, iss%h_shelf, iss%hmask, h_node, cs%min_h_shelf)
1716
1717 do j=g%jsc,g%jec ; do i=g%isc,g%iec
1718 nodefloat = 0
1719
1720 do l=0,1 ; do k=0,1
1721 if ((iss%hmask(i,j) == 1 .or. iss%hmask(i,j)==3) .and. &
1722 (cs%rhoi_rhow * h_node(i-1+k,j-1+l) - cs%bed_elev(i,j) <= 0)) then
1723 nodefloat = nodefloat + 1
1724 endif
1725 enddo ; enddo
1726 if ((nodefloat > 0) .and. (nodefloat < 4)) then
1727 cs%float_cond(i,j) = 1.0
1728 cs%ground_frac(i,j) = 1.0
1729 endif
1730 enddo ; enddo
1731
1732 call pass_var(cs%float_cond, g%Domain, complete=.false.)
1733 call pass_var(cs%ground_frac, g%domain, complete=.true.)
1734
1735 endif
1736
1737 ! Calculate basal drag constants and initial velocity
1738 call calc_shelf_basal_prefactors(cs, iss, g, us)
1739 call calc_shelf_visc(cs, iss, g, us, u_shlf, v_shlf)
1740 if (cs%doing_newton) then
1741 ! halo pass for ice_visc, newton_str_sh, newton_visc_factor, newton_str_x
1742 call do_group_pass(cs%pass_visc_and_newton, g%domain)
1743 else
1744 call pass_var(cs%ice_visc, g%domain, complete=.true.)
1745 endif
1746
1747 ! Calculate err_init, the denominator for some convergence criteria
1748 if (cs%nonlin_solve_err_mode == 1 .or. cs%nonlin_solve_err_mode == 4) then
1749 au(:,:) = 0.0 ; av(:,:) = 0.0
1750 call cg_action(cs, au, av, u_shlf, v_shlf, cs%Phi, cs%Phisub, cs%umask, cs%vmask, iss%hmask, h_node, &
1751 cs%ice_visc, cs%float_cond, cs%bed_elev, u_shlf, v_shlf, &
1752 g, us, g%isc-1, g%iec+1, g%jsc-1, g%jec+1, cs%rhoi_rhow, use_newton_in=.false.)
1753 call pass_vector(au, av, g%domain, to_all, bgrid_ne) ! TODO: is this needed?
1754 endif
1755
1756 if (cs%nonlin_solve_err_mode == 1) then
1757 err_init = 0 ; err_tempu = 0 ; err_tempv = 0
1758 do j=g%JscB,g%JecB ; do i=g%IscB,g%IecB
1759 if (cs%umask(i,j) == 1) then
1760 err_tempu = abs(au(i,j) - taudx(i,j))
1761 if (err_tempu >= err_init) err_init = err_tempu
1762 endif
1763 if (cs%vmask(i,j) == 1) then
1764 err_tempv = abs(av(i,j) - taudy(i,j))
1765 if (err_tempv >= err_init) err_init = err_tempv
1766 endif
1767 enddo ; enddo
1768 call max_across_pes(err_init)
1769
1770 elseif (cs%nonlin_solve_err_mode == 3) then
1771 normvec(:,:) = 0.0
1772 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
1773 if (cs%umask(i,j) == 1) normvec(i,j) = (u_shlf(i,j)**2)
1774 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + (v_shlf(i,j)**2)
1775 enddo ; enddo
1776 norm = sqrt( reproducing_sum( normvec, is_sum, ie_sum, js_sum, je_sum, unscale=us%L_T_to_m_s**2 ) )
1777
1778 elseif (cs%nonlin_solve_err_mode == 4) then
1779 normvec(:,:) = 0.0
1780 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
1781 if (cs%umask(i,j) == 1) normvec(i,j) = ((au(i,j) - taudx(i,j))**2)
1782 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + ((av(i,j) - taudy(i,j))**2)
1783 enddo ; enddo
1784 err_init = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
1785 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
1786 endif
1787
1788 if (cs%nonlin_solve_err_mode == 5 .or. cs%ssa_add_rel_resid) then
1789 normvec(:,:) = 0.0
1790 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
1791 if (cs%umask(i,j) == 1) normvec(i,j) = (taudx(i,j)**2)
1792 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + (taudy(i,j)**2)
1793 enddo ; enddo
1794 if (cs%nonlin_solve_err_mode == 5) then
1795 err_init = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
1796 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
1797 else
1798 norm_tau = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
1799 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
1800 endif
1801 endif
1802
1803 u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:)
1804 if (cs%doing_newton) then
1805 cs%cg_tol_current = cs%cg_newton_tolerance
1806 else
1807 cs%cg_tol_current = cs%cg_tolerance
1808 endif
1809 ew_prev_resid = 0.0
1810 converged = .false.
1811 calc_au_for_convergence = (cs%nonlin_solve_err_mode == 1 .or. cs%nonlin_solve_err_mode == 4 .or. &
1812 cs%nonlin_solve_err_mode == 5 .or. cs%ssa_add_rel_resid)
1813
1814 ! Newton divergence rescue state. The working switch threshold is per-solve: rescues
1815 ! reduce it tenfold, and the configured value is restored at the next solve.
1816 rescue_enabled = cs%newton_divergence_rescue .and. (cs%newton_after_tolerance > 0.0)
1817 newton_after_tol_loc = cs%newton_after_tolerance
1818 newton_armed = .false.
1819 err_newton_enter = 0.0 ; norm_newton_enter = 0.0
1820 n_rescue = 0
1821
1822 !! begin loop
1823
1824 iter = 0
1825 do
1826 iter = iter + 1
1827 if (iter > 50) exit
1828
1829 ! The linear solve
1830 call ice_shelf_solve_inner(cs, iss, g, us, u_shlf, v_shlf, taudx, taudy, h_node, cs%float_cond, &
1831 iss%hmask, conv_flag, iters, time, cs%Phi, cs%Phisub)
1832
1833 if (cs%debug) then
1834 call qchksum(u_shlf, "u shelf", g%HI, haloshift=2, unscale=us%L_T_to_m_s)
1835 call qchksum(v_shlf, "v shelf", g%HI, haloshift=2, unscale=us%L_T_to_m_s)
1836 endif
1837
1838 write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations"
1839 call mom_mesg(mesg, 5)
1840
1841 ! Update viscosity
1842 call calc_shelf_visc(cs, iss, g, us, u_shlf, v_shlf)
1843
1844 if (cs%doing_newton) then
1845 ! halo pass for ice_visc, newton_str_sh, newton_visc_factor, newton_str_x
1846 call do_group_pass(cs%pass_visc_and_newton, g%domain)
1847 else
1848 call pass_var(cs%ice_visc, g%domain, complete=.true.)
1849 endif
1850
1851 ! Calculate convergence norms
1852 if (calc_au_for_convergence) then
1853 au(:,:) = 0 ; av(:,:) = 0
1854 call cg_action(cs, au, av, u_shlf, v_shlf, cs%Phi, cs%Phisub, cs%umask, cs%vmask, iss%hmask, &
1855 h_node, cs%ice_visc, cs%float_cond, cs%bed_elev, u_shlf, v_shlf, &
1856 g, us, g%isc-1, g%iec+1, g%jsc-1, g%jec+1, cs%rhoi_rhow, use_newton_in=.false.)
1857
1858 if (cs%nonlin_solve_err_mode == 1) then
1859 err_max = 0
1860
1861 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1862 if (cs%umask(i,j) == 1) then
1863 err_tempu = abs(au(i,j) - taudx(i,j))
1864 if (err_tempu >= err_max) err_max = err_tempu
1865 endif
1866 if (cs%vmask(i,j) == 1) then
1867 err_tempv = abs(av(i,j) - taudy(i,j))
1868 if (err_tempv >= err_max) err_max = err_tempv
1869 endif
1870 enddo ; enddo
1871
1872 call max_across_pes(err_max)
1873 endif
1874
1875 if (cs%nonlin_solve_err_mode == 4 .or. cs%nonlin_solve_err_mode == 5 .or. cs%ssa_add_rel_resid) then
1876 normvec(:,:) = 0.0
1877 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
1878 if (cs%umask(i,j) == 1) normvec(i,j) = ((au(i,j) - taudx(i,j))**2)
1879 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + ((av(i,j) - taudy(i,j))**2)
1880 enddo ; enddo
1881 if (cs%nonlin_solve_err_mode == 4 .or. cs%nonlin_solve_err_mode == 5) then
1882 err_max = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
1883 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
1884 if (cs%ssa_add_rel_resid) err_rr = err_max
1885 elseif (cs%ssa_add_rel_resid) then
1886 err_rr = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
1887 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
1888 endif
1889 endif
1890 endif
1891
1892 if (cs%nonlin_solve_err_mode == 2) then
1893
1894 err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0
1895 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
1896 if (cs%umask(i,j) == 1) then
1897 err_tempu = abs(u_last(i,j)-u_shlf(i,j))
1898 if (err_tempu >= err_max) err_max = err_tempu
1899 tempu = u_shlf(i,j)
1900 else
1901 tempu = 0.0
1902 endif
1903 if (cs%vmask(i,j) == 1) then
1904 err_tempv = max(abs(v_last(i,j)-v_shlf(i,j)), err_tempu)
1905 if (err_tempv >= err_max) err_max = err_tempv
1906 tempv = sqrt((v_shlf(i,j)**2) + (tempu**2))
1907 endif
1908 if (tempv >= max_vel) max_vel = tempv
1909 enddo ; enddo
1910
1911 u_last(:,:) = u_shlf(:,:)
1912 v_last(:,:) = v_shlf(:,:)
1913
1914 call max_across_pes(max_vel)
1915 call max_across_pes(err_max)
1916 err_init = max_vel
1917
1918 elseif (cs%nonlin_solve_err_mode == 3) then
1919 prevnorm = norm ; norm = 0.0 ; normvec=0.0
1920 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
1921 if (cs%umask(i,j) == 1) normvec(i,j) = (u_shlf(i,j)**2)
1922 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + (v_shlf(i,j)**2)
1923 enddo ; enddo
1924 norm = sqrt( reproducing_sum( normvec, is_sum, ie_sum, js_sum, je_sum, unscale=us%L_T_to_m_s**2 ) )
1925 err_max = 2.*abs(norm-prevnorm) ; err_init = norm+prevnorm
1926 endif
1927
1928 !Test convergence
1929 if (err_max <= cs%nonlinear_tolerance * err_init) then
1930 if (cs%ssa_add_rel_resid) then
1931 if (err_rr <= cs%rr_nonlinear_tolerance * norm_tau) converged = .true.
1932 else
1933 converged = .true.
1934 endif
1935 endif
1936
1937 if (converged) then
1938 exit
1939 else
1940 write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init
1941 call mom_mesg(mesg, 5)
1942
1943 if (cs%ssa_add_rel_resid) then
1944 write(mesg,*) "ice_shelf_solve_outer: nonlinear relative stress residual = ", err_rr/norm_tau
1945 call mom_mesg(mesg, 5)
1946 endif
1947
1948 ! Newton divergence rescue: if the residual has gone NaN or grown beyond
1949 ! NEWTON_DIVERGENCE_FACTOR times its value at the Picard-to-Newton switch,
1950 ! Newton was activated outside its basin of attraction. Restore the
1951 ! pre-Newton iterate, revert to Picard with a fresh outer-iteration budget,
1952 ! and lower the working switch threshold tenfold.
1953 if (rescue_enabled .and. cs%doing_newton .and. newton_armed) then
1954 diverging = (is_nan(err_max)) .or. &
1955 (err_max > cs%newton_divergence_factor * err_newton_enter)
1956 if (diverging) then
1957 n_rescue = n_rescue + 1
1958 u_shlf(:,:) = u_pre_newton(:,:) ; v_shlf(:,:) = v_pre_newton(:,:)
1959 u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:)
1960 if (cs%nonlin_solve_err_mode == 3) norm = norm_newton_enter
1961 cs%doing_newton = .false. ; newton_armed = .false.
1962 ew_prev_resid = 0.0
1963 cs%cg_tol_current = cs%cg_tolerance
1964 if (n_rescue >= cs%newton_max_rescues) then
1965 ! Rescue budget exhausted: pure Picard for the remainder of this solve.
1966 newton_after_tol_loc = 0.0
1967 else
1968 newton_after_tol_loc = 0.1 * newton_after_tol_loc
1969 endif
1970 iter = 0
1971 ! Rebuild the (Picard) viscosity of the restored iterate so the next
1972 ! inner solve does not reuse operators from the divergent state.
1973 call calc_shelf_visc(cs, iss, g, us, u_shlf, v_shlf)
1974 call pass_var(cs%ice_visc, g%domain, complete=.true.)
1975 write(mesg,*) "ice_shelf_solve_outer: Newton diverged (rescue ", n_rescue, &
1976 "); restored pre-Newton state, switch threshold now ", newton_after_tol_loc
1977 call mom_mesg(mesg, 5)
1978 cycle
1979 endif
1980 endif
1981
1982 ! Activate Newton
1983 if (err_max <= newton_after_tol_loc * err_init .and. .not. cs%doing_newton) then
1984 if (rescue_enabled) then
1985 ! Save the switch state so a divergent Newton excursion can be undone.
1986 u_pre_newton(:,:) = u_shlf(:,:) ; v_pre_newton(:,:) = v_shlf(:,:)
1987 err_newton_enter = err_max
1988 if (cs%nonlin_solve_err_mode == 3) norm_newton_enter = norm
1989 newton_armed = .true.
1990 endif
1991 cs%doing_newton = .true.
1992 write(mesg,*) "ice_shelf_solve_outer: switching to Newton iterations at iter = ", iter
1993 call mom_mesg(mesg, 7)
1994 ! halo pass for newton_str_sh, newton_visc_factor, newton_str_x
1995 call do_group_pass(cs%pass_newton, g%domain)
1996 cs%cg_tol_current = cs%cg_newton_tolerance
1997 endif
1998
1999 ! Inexact Newton: Adapt inner solver tolerance to prevent oversolving
2000 ! Based on Eisenstat-Walker Choice II (Eisenstat & Walker 1994): η_k = γ*(||F_k||/||F_{k-1}||)^α
2001 ! with γ=0.9, α=2 as default. Uses the L2 norm of the nonlinear stress residual ||Au - tau||_2,
2002 ! consistent with the inner solver's convergence check (sv3dsums(3)).
2003 ! The first Newton step uses the standard cg_tolerance.
2004 if (cs%doing_newton .and. cs%newton_adapt_cg_tol) then
2005 !calculate residual needed for EW; some convergence criteria already did this
2006 if (cs%nonlin_solve_err_mode >= 4) then
2007 ew_resid=err_max
2008 elseif (cs%ssa_add_rel_resid) then
2009 ew_resid=err_rr
2010 else
2011 if (.not. calc_au_for_convergence) then
2012 au(:,:) = 0 ; av(:,:) = 0
2013 call cg_action(cs, au, av, u_shlf, v_shlf, cs%Phi, cs%Phisub, cs%umask, cs%vmask, iss%hmask, &
2014 h_node, cs%ice_visc, cs%float_cond, cs%bed_elev, u_shlf, v_shlf, &
2015 g, us, g%isc-1, g%iec+1, g%jsc-1, g%jec+1, cs%rhoi_rhow, use_newton_in=.false.)
2016 endif
2017 normvec(:,:) = 0.0
2018 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2019 if (cs%umask(i,j) == 1) normvec(i,j) = ((au(i,j) - taudx(i,j))**2)
2020 if (cs%vmask(i,j) == 1) normvec(i,j) = normvec(i,j) + ((av(i,j) - taudy(i,j))**2)
2021 enddo ; enddo
2022 ew_resid = sqrt(reproducing_sum(normvec, is_sum, ie_sum, js_sum, je_sum, &
2023 unscale=((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2))
2024 endif
2025
2026 if (ew_prev_resid == 0.0) then
2027 ! First Newton iteration: seed residuals; use initial newton cg_tolerance this step
2028 ew_prev_resid = ew_resid
2029 cs%cg_tol_current = cs%cg_newton_tolerance
2030 ew_eta_prev = cs%cg_tol_current
2031 else
2032 ! Safeguarding and oversolving adjustments:
2033 ! Eisenstat-Walker Choice II safeguard base formula
2034 ew_eta = cs%ew_gamma * (ew_resid / ew_prev_resid)**cs%ew_alpha
2035 ew_stol = cs%ew_gamma * ew_eta_prev**cs%ew_alpha
2036 !Safeguards to sharp decrease/oversolving:
2037 if (cs%ew_safety==1) then
2038 ! Eisenstat-Walker Choice II safeguard:
2039 write(mesg,*) "ice_shelf_solve_outer: ew_stol = ", ew_stol
2040 call mom_mesg(mesg, 8)
2041 if (ew_stol > cs%ew_1_thres) ew_eta = max(ew_eta, ew_stol)
2042 elseif (cs%ew_safety==2) then
2043 ! PETSc choice 3 safeguard (e,g, Chacon 2008, J. Phys: Conf. Ser. 125 012041):
2044 ! Avoid steep decreases in ew_eta
2045 ew_eta = min(cs%cg_newton_tolerance, max(ew_eta, ew_stol))
2046 ! Avoid oversolving in last Newton iters:
2047 ! The original is technically only applicable for nonlin_solve_err_mode=4:
2048 ! ew_stol = CS%ew_gamma * ew_resid_first * CS%nonlinear_tolerance / ew_resid
2049 ! Here, adapt for all nonlin_solve_err_modes:
2050 ew_stol = cs%ew_gamma * err_init * cs%nonlinear_tolerance / err_max
2051 if (cs%ssa_add_rel_resid) then
2052 ew_stol = min(ew_stol, cs%ew_gamma * norm_tau * cs%rr_nonlinear_tolerance / err_rr)
2053 endif
2054 ew_eta = min(cs%cg_newton_tolerance, max(ew_eta, ew_stol))
2055 write(mesg,*) "ice_shelf_solve_outer: ew_stol = ", ew_stol
2056 call mom_mesg(mesg, 8)
2057 endif
2058 ew_eta = min(ew_eta,cs%ew_eta_max)
2059 cs%cg_tol_current = ew_eta
2060 ew_eta_prev = ew_eta
2061 ew_prev_resid = ew_resid
2062 write(mesg,*) "ice_shelf_solve_outer: New inner tolerance = ", cs%cg_tol_current
2063 call mom_mesg(mesg, 8)
2064 endif
2065 endif
2066 endif
2067 enddo
2068 cs%doing_newton = .false.
2069 cs%cg_tol_current = cs%cg_tolerance
2070
2071 write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init
2072 call mom_mesg(mesg)
2073 if (cs%ssa_add_rel_resid) then
2074 write(mesg,*) "ice_shelf_solve_outer: nonlinear relative residual = ", err_rr/norm_tau
2075 call mom_mesg(mesg, 5)
2076 endif
2077 write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations"
2078 call mom_mesg(mesg)
2079
2080end subroutine ice_shelf_solve_outer
2081
2082!> Unified inner linear solver for ice shelf velocity.
2083!! Performs shared setup (RHS, preconditioner, initial matrix-vector product),
2084!! dispatches to the selected Krylov method, and applies boundary conditions.
2085subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, &
2086 hmask, conv_flag, iters, time, Phi, Phisub)
2087 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
2088 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state
2089 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
2090 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
2091 real, dimension(SZDIB_(G),SZDJB_(G)), &
2092 intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1]
2093 real, dimension(SZDIB_(G),SZDJB_(G)), &
2094 intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1]
2095 real, dimension(SZDIB_(G),SZDJB_(G)), &
2096 intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2]
2097 real, dimension(SZDIB_(G),SZDJB_(G)), &
2098 intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2]
2099 real, dimension(SZDIB_(G),SZDJB_(G)), &
2100 intent(in) :: H_node !< The ice shelf thickness at nodal (corner) points [Z ~> m].
2101 real, dimension(SZDI_(G),SZDJ_(G)), &
2102 intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing
2103 !! the grounding line (float_cond=1) or not (float_cond=0)
2104 real, dimension(SZDI_(G),SZDJ_(G)), &
2105 intent(in) :: hmask !< A mask indicating which tracer points are
2106 !! partly or fully covered by an ice-shelf
2107 integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the
2108 !! iterations have converged to the specified tolerance
2109 integer, intent(out) :: iters !< The number of iterations used in the solver.
2110 type(time_type), intent(in) :: Time !< The current model time
2111 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
2112 intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian
2113 !! quadrature points surrounding the cell vertices [L-1 ~> m-1].
2114 real, dimension(:,:,:,:,:,:), &
2115 intent(in) :: Phisub !< Quadrature structure weights at subgridscale
2116 !! locations for finite element calculations [nondim]
2117
2118 real, dimension(SZDIB_(G),SZDJB_(G)) :: &
2119 RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2]
2120 Au, Av, & ! Matrix-vector product A*x [R L3 Z T-2 ~> kg m s-2]
2121 DIAGu, DIAGv, & ! Diagonals [R L2 Z T-1 ~> kg s-1]
2122 IDIAGu, IDIAGv ! Reciprocal diagonals [R-1 L-2 Z-1 T ~> kg-1 s]
2123 real :: resid_scale ! A scaling factor for redimensionalizing the global residuals
2124 ! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1]
2125 integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1.
2126 integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec arrays
2127 integer :: I, J
2128 integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq
2129 integer :: isc, iec, jsc, jec
2130
2131 isdq = g%IsdB ; iedq = g%IedB ; jsdq = g%JsdB ; jedq = g%JedB
2132 iscq = g%IscB ; iecq = g%IecB ; jscq = g%JscB ; jecq = g%JecB
2133 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
2134
2135 ! Initialize shared arrays
2136 au(:,:) = 0 ; av(:,:) = 0 ; diagu(:,:) = 0 ; diagv(:,:) = 0
2137
2138 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1.
2139 ! Includes the edge of the tile is at the western/southern bdry (if symmetric)
2140 if ((isc+g%idg_offset==g%isg) .and. (.not. cs%reentrant_x)) then
2141 is_sum = iscq + (1-isdq) ; iscq_sv = iscq
2142 else
2143 is_sum = isc + (1-isdq) ; iscq_sv = isc
2144 endif
2145 if ((jsc+g%jdg_offset==g%jsg) .and. (.not. cs%reentrant_y)) then
2146 js_sum = jscq + (1-jsdq) ; jscq_sv = jscq
2147 else
2148 js_sum = jsc + (1-jsdq) ; jscq_sv = jsc
2149 endif
2150 ie_sum = iecq + (1-isdq) ; je_sum = jecq + (1-jsdq)
2151
2152 rhsu(:,:) = taudx(:,:) ; rhsv(:,:) = taudy(:,:)
2153 call pass_vector(rhsu, rhsv, g%domain, to_all, bgrid_ne, complete=.false.)
2154
2155 call matrix_diagonal(cs, g, us, float_cond, h_node, cs%ice_visc, u_shlf, v_shlf, &
2156 hmask, cs%rhoi_rhow, phi, phisub, diagu, diagv)
2157 call pass_vector(diagu, diagv, g%domain, to_all, bgrid_ne, complete=.false.)
2158
2159 call cg_action(cs, au, av, u_shlf, v_shlf, phi, phisub, cs%umask, cs%vmask, hmask, &
2160 h_node, cs%ice_visc, float_cond, cs%bed_elev, u_shlf, v_shlf, &
2161 g, us, isc-1, iec+1, jsc-1, jec+1, cs%rhoi_rhow, use_newton_in=.false.)
2162 call pass_vector(au, av, g%domain, to_all, bgrid_ne, complete=.true.)
2163
2164 ! Precompute reciprocal diagonal
2165 idiagu(:,:) = 0.0 ; idiagv(:,:) = 0.0
2166 do j=jsdq,jedq ; do i=isdq,iedq
2167 if (cs%umask(i,j)==1 .AND. diagu(i,j)/=0) idiagu(i,j) = 1.0 / diagu(i,j)
2168 if (cs%vmask(i,j)==1 .AND. diagv(i,j)/=0) idiagv(i,j) = 1.0 / diagv(i,j)
2169 enddo ; enddo
2170
2171 resid_scale = us%s_to_T*(us%RZL2_to_kg*us%L_T_to_m_s**2)
2172
2173 ! Dispatch to selected solver
2174 select case (cs%inner_solver)
2175 case (inner_cg)
2176 call ice_shelf_solve_inner_cg(cs, g, us, u_shlf, v_shlf, rhsu, rhsv, au, av, &
2177 idiagu, idiagv, h_node, float_cond, hmask, &
2178 cs%rhoi_rhow, resid_scale, phi, phisub, conv_flag, iters, &
2179 is_sum, js_sum, ie_sum, je_sum, iscq_sv, jscq_sv)
2180 case (inner_minres)
2181 call ice_shelf_solve_inner_minres(cs, g, us, u_shlf, v_shlf, rhsu, rhsv, au, av, &
2182 idiagu, idiagv, h_node, float_cond, hmask, &
2183 cs%rhoi_rhow, resid_scale, phi, phisub, conv_flag, iters, &
2184 is_sum, js_sum, ie_sum, je_sum, iscq_sv, jscq_sv)
2185 case (inner_cr)
2186 call ice_shelf_solve_inner_cr(cs, g, us, u_shlf, v_shlf, rhsu, rhsv, au, av, &
2187 idiagu, idiagv, h_node, float_cond, hmask, &
2188 cs%rhoi_rhow, resid_scale, phi, phisub, conv_flag, iters, &
2189 is_sum, js_sum, ie_sum, je_sum, iscq_sv, jscq_sv)
2190 end select
2191
2192 ! Shared teardown: Apply boundary conditions
2193 do j=jsdq,jedq ; do i=isdq,iedq
2194 if (cs%umask(i,j) == 3) then
2195 u_shlf(i,j) = cs%u_bdry_val(i,j)
2196 elseif (cs%umask(i,j) == 0) then
2197 u_shlf(i,j) = 0
2198 endif
2199
2200 if (cs%vmask(i,j) == 3) then
2201 v_shlf(i,j) = cs%v_bdry_val(i,j)
2202 elseif (cs%vmask(i,j) == 0) then
2203 v_shlf(i,j) = 0
2204 endif
2205 enddo ; enddo
2206
2207 call pass_vector(u_shlf, v_shlf, g%domain, to_all, bgrid_ne)
2208
2209 if (conv_flag == 0) then
2210 iters = cs%cg_max_iterations
2211 endif
2212
2213end subroutine ice_shelf_solve_inner
2214
2215!> CG (Conjugate Gradient) inner Krylov solve for ice shelf velocity.
2216subroutine ice_shelf_solve_inner_cg(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, &
2217 IDIAGu, IDIAGv, H_node, float_cond, hmask, &
2218 rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, &
2219 Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv)
2220 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
2221 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
2222 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
2223 real, dimension(SZDIB_(G),SZDJB_(G)), &
2224 intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]
2225 real, dimension(SZDIB_(G),SZDJB_(G)), &
2226 intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]
2227 real, dimension(SZDIB_(G),SZDJB_(G)), &
2228 intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2]
2229 real, dimension(SZDIB_(G),SZDJB_(G)), &
2230 intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2]
2231 real, dimension(SZDIB_(G),SZDJB_(G)), &
2232 intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2]
2233 real, dimension(SZDIB_(G),SZDJB_(G)), &
2234 intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2]
2235 real, dimension(SZDIB_(G),SZDJB_(G)), &
2236 intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s]
2237 real, dimension(SZDIB_(G),SZDJB_(G)), &
2238 intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s]
2239 real, dimension(SZDIB_(G),SZDJB_(G)), &
2240 intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m]
2241 real, dimension(SZDI_(G),SZDJ_(G)), &
2242 intent(in) :: float_cond !< Grounding line indicator [nondim]
2243 real, dimension(SZDI_(G),SZDJ_(G)), &
2244 intent(in) :: hmask !< Ice shelf coverage mask
2245 real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim]
2246 real, intent(in) :: resid_scale !< Scaling for inner products
2247 !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1]
2248 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
2249 intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1]
2250 real, dimension(:,:,:,:,:,:), &
2251 intent(in) :: Phisub !< Subgridscale quadrature weights [nondim]
2252 integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not
2253 integer, intent(out) :: iters !< The number of iterations used
2254 integer, intent(in) :: Is_sum !< Starting i-index for global sums
2255 integer, intent(in) :: Js_sum !< Starting j-index for global sums
2256 integer, intent(in) :: Ie_sum !< Ending i-index for global sums
2257 integer, intent(in) :: Je_sum !< Ending j-index for global sums
2258 integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays
2259 integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays
2260
2261 real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction
2262 !! at quadrature points [L T-1 ~> m s-1]
2263 real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction
2264 !! at quadrature points [L T-1 ~> m s-1]
2265 real, dimension(SZDIB_(G),SZDJB_(G)) :: &
2266 Ru, Rv, & ! Residuals [R L3 Z T-2 ~> m kg s-2]
2267 Zu, Zv, & ! Preconditioned residuals [L T-1 ~> m s-1]
2268 Du, Dv ! Search directions [L T-1 ~> m s-1]
2269 real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec ! Pointwise D·A products for the alpha_k global sum
2270 ! [kg m2 s-3]
2271 real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Array used for various residuals
2272 ! sum_vec_3d(:,:,1) [kg m2 s-3]
2273 ! sum_vec_3d(:,:,2) [kg2 m2 s-4]
2274 real :: beta_k ! Ratio of residuals used to update search direction [nondim]
2275 real :: resid0tol2 ! Convergence tolerance times the initial residual [m2 kg2 s-4]
2276 real :: sv3dsum ! An unused variable returned when taking global sum of residuals [various]
2277 real :: sv3dsums(2) ! The index-wise global sums of sum_vec_3d
2278 ! sv3dsums(1) [kg m2 s-3]
2279 ! sv3dsums(2) [kg2 m2 s-4]
2280 real :: alpha_k ! A scaling factor for iterative corrections [nondim]
2281 real :: rho_old ! The preconditioned residual inner product Z·R from the previous CG
2282 ! iteration, scaled by resid_scale [kg m2 s-3]
2283 real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals
2284 ! [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1]
2285 integer :: cg_halo ! Number of halo vertices to include during a CG iteration
2286 integer :: max_cg_halo ! Maximum possible number of halo vertices to include in the CG iterations
2287 integer :: iter, i, j, isc, iec, jsc, jec, is, js, ie, je, is2, ie2, js2, je2
2288 integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo
2289
2290 isdq = g%IsdB ; iedq = g%IedB ; jsdq = g%JsdB ; jedq = g%JedB
2291 iscq = g%IscB ; iecq = g%IecB ; jscq = g%JscB ; jecq = g%JecB
2292 ny_halo = g%domain%njhalo ; nx_halo = g%domain%nihalo
2293 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
2294
2295 resid2_scale = ((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2
2296
2297 ru(:,:) = 0 ; rv(:,:) = 0 ; zu(:,:) = 0 ; zv(:,:) = 0 ; du(:,:) = 0 ; dv(:,:) = 0
2298
2299 ru(:,:) = (rhsu(:,:) - au(:,:)) ; rv(:,:) = (rhsv(:,:) - av(:,:))
2300
2301 ! current velocities used in CG_action for basal drag
2302 u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:)
2303
2304 do j=jsdq,jedq ; do i=isdq,iedq
2305 if (cs%umask(i,j) == 1) zu(i,j) = ru(i,j) * idiagu(i,j)
2306 if (cs%vmask(i,j) == 1) zv(i,j) = rv(i,j) * idiagv(i,j)
2307 du(i,j) = zu(i,j)
2308 dv(i,j) = zv(i,j)
2309 enddo ; enddo
2310
2311 ! Compute rho_old = Z·R and resid0tol2 before the CG loop
2312 sum_vec_3d(:,:,:) = 0.0
2313 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2314 if (cs%umask(i,j) == 1) then
2315 sum_vec_3d(i,j,1) = resid_scale * (zu(i,j) * ru(i,j))
2316 sum_vec_3d(i,j,2) = resid2_scale * ru(i,j)**2
2317 endif
2318 if (cs%vmask(i,j) == 1) then
2319 sum_vec_3d(i,j,1) = sum_vec_3d(i,j,1) + resid_scale * (zv(i,j) * rv(i,j))
2320 sum_vec_3d(i,j,2) = sum_vec_3d(i,j,2) + resid2_scale * rv(i,j)**2
2321 endif
2322 enddo ; enddo
2323
2324 sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), is_sum, ie_sum, js_sum, je_sum, sums=sv3dsums(1:2) )
2325
2326 rho_old = sv3dsums(1)
2327 !resid0 = sqrt(sv3dsums(2))
2328 resid0tol2 = cs%cg_tol_current**2 * sv3dsums(2)
2329
2330 if (g%symmetric) then
2331 max_cg_halo=min(nx_halo,ny_halo)
2332 else
2333 max_cg_halo=min(nx_halo,ny_halo)-1
2334 endif
2335 cg_halo = max_cg_halo
2336 conv_flag = 0
2337
2338 if (cs%cg_halo_shrink) then
2339 is = isc - cg_halo ; ie = iecq + cg_halo
2340 js = jsc - cg_halo ; je = jecq + cg_halo
2341 is2 = is ; ie2 = ie-1
2342 js2 = js ; je2 = je-1
2343 else
2344 is = isc - 1 ; ie = iec + 1
2345 js = jsc - 1 ; je = jec + 1
2346 is2 = iscq ; ie2 = iecq
2347 js2 = jscq ; je2 = jecq
2348 endif
2349
2350 !!!!!!!!!!!!!!!!!!
2351 !! !!
2352 !! MAIN CG LOOP !!
2353 !! !!
2354 !!!!!!!!!!!!!!!!!!
2355
2356 do iter = 1,cs%cg_max_iterations
2357
2358 au(:,:) = 0 ; av(:,:) = 0
2359
2360 call cg_action(cs, au, av, du, dv, phi, phisub, cs%umask, cs%vmask, hmask, &
2361 h_node, cs%ice_visc, float_cond, cs%bed_elev, u_curr, v_curr, &
2362 g, us, is, ie, js, je, rhoi_rhow)
2363
2364 sum_vec(:,:) = 0.0
2365
2366 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2367 if (cs%umask(i,j) == 1) sum_vec(i,j) = resid_scale * (du(i,j) * au(i,j))
2368 if (cs%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale * (dv(i,j) * av(i,j))
2369 enddo ; enddo
2370
2371 sv3dsum = reproducing_sum( sum_vec(:,:), is_sum, ie_sum, js_sum, je_sum )
2372
2373 if (sv3dsum == 0.0) then
2374 iters = iter
2375 conv_flag = 1
2376 exit
2377 endif
2378
2379 alpha_k = rho_old / sv3dsum
2380
2381 do j=js2,je2 ; do i=is2,ie2
2382 if (cs%umask(i,j) == 1) then
2383 u_shlf(i,j) = u_shlf(i,j) + alpha_k * du(i,j)
2384 ru(i,j) = ru(i,j) - alpha_k * au(i,j)
2385 zu(i,j) = ru(i,j) * idiagu(i,j)
2386 endif
2387 if (cs%vmask(i,j) == 1) then
2388 v_shlf(i,j) = v_shlf(i,j) + alpha_k * dv(i,j)
2389 rv(i,j) = rv(i,j) - alpha_k * av(i,j)
2390 zv(i,j) = rv(i,j) * idiagv(i,j)
2391 endif
2392 enddo ; enddo
2393
2394 ! beta_k = (Z \dot R) / (Z_prev \dot R_prev)
2395 sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(:)=0.0
2396
2397 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2398 if (cs%umask(i,j) == 1) then
2399 sum_vec_3d(i,j,1) = resid_scale * (zu(i,j) * ru(i,j))
2400 sum_vec_3d(i,j,2) = resid2_scale * ru(i,j)**2
2401 endif
2402 if (cs%vmask(i,j) == 1) then
2403 sum_vec_3d(i,j,1) = sum_vec_3d(i,j,1) + resid_scale * (zv(i,j) * rv(i,j))
2404 sum_vec_3d(i,j,2) = sum_vec_3d(i,j,2) + resid2_scale * rv(i,j)**2
2405 endif
2406 enddo ; enddo
2407
2408 sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), is_sum, ie_sum, js_sum, je_sum, sums=sv3dsums(1:2) )
2409
2410 beta_k = sv3dsums(1) / rho_old
2411
2412 if (sv3dsums(2) <= resid0tol2) then
2413 iters = iter
2414 conv_flag = 1
2415 exit
2416 endif
2417
2418 do j=js2,je2 ; do i=is2,ie2
2419 if (cs%umask(i,j) == 1) du(i,j) = zu(i,j) + beta_k * du(i,j)
2420 if (cs%vmask(i,j) == 1) dv(i,j) = zv(i,j) + beta_k * dv(i,j)
2421 enddo ; enddo
2422
2423 rho_old = sv3dsums(1)
2424
2425 if (cs%cg_halo_shrink) then
2426 cg_halo = cg_halo - 1
2427 if (cg_halo == 0) then
2428 call pass_vector(du, dv, g%domain, to_all, bgrid_ne, complete=.false.)
2429 call pass_vector(zu, zv, g%domain, to_all, bgrid_ne, complete=.false.)
2430 call pass_vector(ru, rv, g%domain, to_all, bgrid_ne, complete=.false.)
2431 call pass_vector(u_shlf, v_shlf, g%domain, to_all, bgrid_ne, complete=.true.)
2432 cg_halo = max_cg_halo
2433 endif
2434 is = isc - cg_halo ; ie = iecq + cg_halo
2435 js = jsc - cg_halo ; je = jecq + cg_halo
2436 is2 = is ; ie2 = ie-1
2437 js2 = js ; je2 = je-1
2438 else
2439 call pass_vector(du, dv, g%domain, to_all, bgrid_ne)
2440 endif
2441
2442 enddo ! end of CG loop
2443
2444end subroutine ice_shelf_solve_inner_cg
2445
2446!> MINRES inner Krylov solve for ice shelf velocity.
2447subroutine ice_shelf_solve_inner_minres(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, &
2448 IDIAGu, IDIAGv, H_node, float_cond, hmask, &
2449 rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, &
2450 Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv)
2451 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
2452 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
2453 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
2454 real, dimension(SZDIB_(G),SZDJB_(G)), &
2455 intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]
2456 real, dimension(SZDIB_(G),SZDJB_(G)), &
2457 intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]
2458 real, dimension(SZDIB_(G),SZDJB_(G)), &
2459 intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2]
2460 real, dimension(SZDIB_(G),SZDJB_(G)), &
2461 intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2]
2462 real, dimension(SZDIB_(G),SZDJB_(G)), &
2463 intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2]
2464 real, dimension(SZDIB_(G),SZDJB_(G)), &
2465 intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2]
2466 real, dimension(SZDIB_(G),SZDJB_(G)), &
2467 intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s]
2468 real, dimension(SZDIB_(G),SZDJB_(G)), &
2469 intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s]
2470 real, dimension(SZDIB_(G),SZDJB_(G)), &
2471 intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m]
2472 real, dimension(SZDI_(G),SZDJ_(G)), &
2473 intent(in) :: float_cond !< Grounding line indicator [nondim]
2474 real, dimension(SZDI_(G),SZDJ_(G)), &
2475 intent(in) :: hmask !< Ice shelf coverage mask
2476 real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim]
2477 real, intent(in) :: resid_scale !< Scaling for inner products
2478 !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1]
2479 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
2480 intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1]
2481 real, dimension(:,:,:,:,:,:), &
2482 intent(in) :: Phisub !< Subgridscale quadrature weights [nondim]
2483 integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not
2484 integer, intent(out) :: iters !< The number of iterations used
2485 integer, intent(in) :: Is_sum !< Starting i-index for global sums
2486 integer, intent(in) :: Js_sum !< Starting j-index for global sums
2487 integer, intent(in) :: Ie_sum !< Ending i-index for global sums
2488 integer, intent(in) :: Je_sum !< Ending j-index for global sums
2489 integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays
2490 integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays
2491
2492 real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction
2493 !! at quadrature points [L T-1 ~> m s-1]
2494 real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction
2495 !! at quadrature points [L T-1 ~> m s-1]
2496 real, dimension(SZDIB_(G),SZDJB_(G)) :: &
2497 V_old_u, V_old_v, V_curr_u, V_curr_v, V_new_u, V_new_v, & ! Lanczos basis vectors [R L3 Z T-2 ~> m kg s-2]
2498 Z_curr_u, Z_curr_v, Z_new_u, Z_new_v, & ! Preconditioned Lanczos vectors [L T-1 ~> m s-1]
2499 W_old_u, W_old_v, W_curr_u, W_curr_v, W_new_u, W_new_v, & ! MINRES search directions [L T-1 ~> m s-1]
2500 Qu, Qv ! A * Z_curr [R L3 Z T-2 ~> m kg s-2]
2501 real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec_3d ! Pointwise products for global sums
2502 ! [kg m2 s-3] before normalization;
2503 ! [nondim] inside loop (after Lanczos normalization)
2504 real :: alpha ! Lanczos diagonal element (Rayleigh quotient) [nondim]
2505 real :: beta1 ! Current Lanczos off-diagonal coefficient;
2506 ! initial value [kg^1/2 m s^-3/2], then [nondim] after iter 1
2507 real :: beta2 ! Next Lanczos off-diagonal coefficient [nondim]
2508 real :: eta ! MINRES residual norm estimate [kg^1/2 m s^-3/2]
2509 real :: eta_curr ! Effective step magnitude for current iteration [kg^1/2 m s^-3/2]
2510 real :: c0, s0, c1, s1, c2, s2 ! Givens rotation cosines and sines [nondim]
2511 real :: d0, d1, d2 ! Tridiagonal QR factorization coefficients [nondim]
2512 real :: resid0tol ! Convergence tolerance (CS%cg_tol_newton * beta1) [kg^1/2 m s^-3/2]
2513 real :: current_norm ! Current MINRES residual norm estimate [kg^1/2 m s^-3/2]
2514 real :: sv3dsum ! Global reproducing sum of sum_vec_3d;
2515 ! [kg m2 s-3] before normalization, [nondim] inside loop
2516 real :: Ibeta1 ! Reciprocal of initial beta1 [kg^-1/2 m-1 s^3/2]
2517 real :: Ibeta2 ! Reciprocal of beta2 [nondim]
2518 real :: Id1 ! Reciprocal of d1 [nondim]
2519 integer :: iter, i, j, isc, iec, jsc, jec
2520 integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq
2521
2522 isdq = g%IsdB ; iedq = g%IedB ; jsdq = g%JsdB ; jedq = g%JedB
2523 iscq = g%IscB ; iecq = g%IecB ; jscq = g%JscB ; jecq = g%JecB
2524 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
2525
2526 ! Initialize MINRES-specific arrays
2527 v_old_u(:,:) = 0 ; v_old_v(:,:) = 0 ; v_curr_u(:,:) = 0 ; v_curr_v(:,:) = 0
2528 z_curr_u(:,:) = 0 ; z_curr_v(:,:) = 0
2529 w_old_u(:,:) = 0 ; w_old_v(:,:) = 0 ; w_curr_u(:,:) = 0 ; w_curr_v(:,:) = 0
2530 qu(:,:) = 0 ; qv(:,:) = 0
2531
2532 ! Initial Residual
2533 v_curr_u(:,:) = (rhsu(:,:) - au(:,:)) ; v_curr_v(:,:) = (rhsv(:,:) - av(:,:))
2534
2535 ! current velocities used in CG_action for basal drag
2536 u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:)
2537
2538 do j=jscq,jecq ; do i=iscq,iecq
2539 if (cs%umask(i,j) == 1) z_curr_u(i,j) = v_curr_u(i,j) * idiagu(i,j)
2540 if (cs%vmask(i,j) == 1) z_curr_v(i,j) = v_curr_v(i,j) * idiagv(i,j)
2541 enddo ; enddo
2542
2543 sum_vec_3d(:,:) = 0.0
2544 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2545 if (cs%umask(i,j) == 1) sum_vec_3d(i,j) = resid_scale * (v_curr_u(i,j) * z_curr_u(i,j))
2546 if (cs%vmask(i,j) == 1) sum_vec_3d(i,j) = sum_vec_3d(i,j) + resid_scale * (v_curr_v(i,j) * z_curr_v(i,j))
2547 enddo ; enddo
2548 sv3dsum = reproducing_sum( sum_vec_3d(:,:), is_sum, ie_sum, js_sum, je_sum )
2549
2550 beta1 = sqrt(abs(sv3dsum))
2551
2552 if (beta1 == 0.0) then
2553 conv_flag = 1
2554 iters = 0
2555 return
2556 endif
2557
2558 ibeta1 = 1.0/beta1
2559
2560 ! Normalize initial Lanczos vectors
2561 do j=jscq,jecq ; do i=iscq,iecq
2562 if (cs%umask(i,j) == 1) then
2563 v_curr_u(i,j) = v_curr_u(i,j) * ibeta1
2564 z_curr_u(i,j) = z_curr_u(i,j) * ibeta1
2565 endif
2566 if (cs%vmask(i,j) == 1) then
2567 v_curr_v(i,j) = v_curr_v(i,j) * ibeta1
2568 z_curr_v(i,j) = z_curr_v(i,j) * ibeta1
2569 endif
2570 enddo ; enddo
2571
2572 ! Sync Z_curr prior to entering the loop
2573 call pass_vector(z_curr_u, z_curr_v, g%domain, to_all, bgrid_ne)
2574
2575 eta = beta1
2576 resid0tol = cs%cg_tol_current * beta1
2577 conv_flag = 0
2578
2579 c0 = 1.0 ; s0 = 0.0 ; c1 = 1.0 ; s1 = 0.0
2580
2581 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2582 !! !!
2583 !! MAIN MINRES LANCZOS LOOP !!
2584 !! !!
2585 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2586
2587 do iter = 1, cs%cg_max_iterations
2588
2589 ! --- STEP 1: Matrix Vector Product ---
2590 qu(:,:) = 0 ; qv(:,:) = 0
2591 call cg_action(cs, qu, qv, z_curr_u, z_curr_v, phi, phisub, cs%umask, cs%vmask, hmask, &
2592 h_node, cs%ice_visc, float_cond, cs%bed_elev, u_curr, v_curr, &
2593 g, us, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow)
2594 ! --- STEP 2: alpha = q dot z_curr ---
2595 sum_vec_3d(:,:) = 0.0
2596 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2597 if (cs%umask(i,j) == 1) sum_vec_3d(i,j) = resid_scale * (qu(i,j) * z_curr_u(i,j))
2598 if (cs%vmask(i,j) == 1) sum_vec_3d(i,j) = sum_vec_3d(i,j) + resid_scale * (qv(i,j) * z_curr_v(i,j))
2599 enddo ; enddo
2600 sv3dsum = reproducing_sum( sum_vec_3d(:,:), is_sum, ie_sum, js_sum, je_sum )
2601 alpha = sv3dsum
2602
2603 ! --- FUSED STEPS 3 & 4: Update V_new and Precondition to Z_new ---
2604 do j=jscq,jecq ; do i=iscq,iecq
2605 if (cs%umask(i,j) == 1) then
2606 v_new_u(i,j) = qu(i,j) - alpha * v_curr_u(i,j) - beta1 * v_old_u(i,j)
2607 z_new_u(i,j) = v_new_u(i,j) * idiagu(i,j)
2608 endif
2609 if (cs%vmask(i,j) == 1) then
2610 v_new_v(i,j) = qv(i,j) - alpha * v_curr_v(i,j) - beta1 * v_old_v(i,j)
2611 z_new_v(i,j) = v_new_v(i,j) * idiagv(i,j)
2612 endif
2613 enddo ; enddo
2614
2615 ! --- STEP 5: beta2 = sqrt(v_new dot z_new) ---
2616 sum_vec_3d(:,:) = 0.0
2617 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2618 if (cs%umask(i,j) == 1) sum_vec_3d(i,j) = resid_scale * (v_new_u(i,j) * z_new_u(i,j))
2619 if (cs%vmask(i,j) == 1) sum_vec_3d(i,j) = sum_vec_3d(i,j) + resid_scale * (v_new_v(i,j) * z_new_v(i,j))
2620 enddo ; enddo
2621 sv3dsum = reproducing_sum( sum_vec_3d(:,:), is_sum, ie_sum, js_sum, je_sum )
2622 beta2 = sqrt(abs(sv3dsum))
2623
2624 ! --- STEP 6: Apply Givens Rotations ---
2625 d0 = c1 * alpha - c0 * s1 * beta1
2626 d1 = sqrt(d0**2 + beta2**2)
2627
2628 if (d1 == 0.0) then
2629 iters = iter
2630 conv_flag = 1
2631 exit
2632 endif
2633
2634 id1 = 1.0 / d1
2635 if (beta2 > 0) ibeta2 = 1.0 / beta2
2636
2637 d2 = s1 * alpha + c0 * c1 * beta1
2638 c2 = d0 * id1
2639 s2 = beta2 * id1
2640
2641 eta_curr = c2 * eta
2642 eta = -s2 * eta
2643 current_norm = abs(eta)
2644
2645 ! --- FUSED STEPS 7 & 9: Update u/v, Check Convergence, and Shift Vectors ---
2646 do j=jscq,jecq ; do i=iscq,iecq
2647 if (cs%umask(i,j) == 1) then
2648 w_new_u(i,j) = (z_curr_u(i,j) - (d2 * w_curr_u(i,j) + beta1 * s0 * w_old_u(i,j))) * id1
2649 u_shlf(i,j) = u_shlf(i,j) + eta_curr * w_new_u(i,j)
2650 if (beta2 > 0.0) then
2651 v_old_u(i,j) = v_curr_u(i,j)
2652 v_curr_u(i,j) = v_new_u(i,j) * ibeta2
2653 z_curr_u(i,j) = z_new_u(i,j) * ibeta2
2654 w_old_u(i,j) = w_curr_u(i,j)
2655 w_curr_u(i,j) = w_new_u(i,j)
2656 endif
2657 endif
2658 if (cs%vmask(i,j) == 1) then
2659 w_new_v(i,j) = (z_curr_v(i,j) - (d2 * w_curr_v(i,j) + beta1 * s0 * w_old_v(i,j))) * id1
2660 v_shlf(i,j) = v_shlf(i,j) + eta_curr * w_new_v(i,j)
2661 if (beta2 > 0.0) then
2662 v_old_v(i,j) = v_curr_v(i,j)
2663 v_curr_v(i,j) = v_new_v(i,j) * ibeta2
2664 z_curr_v(i,j) = z_new_v(i,j) * ibeta2
2665 w_old_v(i,j) = w_curr_v(i,j)
2666 w_curr_v(i,j) = w_new_v(i,j)
2667 endif
2668 endif
2669 enddo ; enddo
2670
2671 ! --- STEP 8: Check Convergence ---
2672 if (current_norm <= resid0tol .or. beta2 == 0.0) then
2673 iters = iter
2674 conv_flag = 1
2675 exit
2676 endif
2677
2678 ! Sync Z_curr for the next iteration's CG_action
2679 call pass_vector(z_curr_u, z_curr_v, g%domain, to_all, bgrid_ne)
2680
2681 beta1 = beta2
2682 c0 = c1 ; c1 = c2
2683 s0 = s1 ; s1 = s2
2684
2685 enddo ! end of MINRES loop
2686
2687end subroutine ice_shelf_solve_inner_minres
2688
2689!> CR (Conjugate Residual) inner Krylov solve for ice shelf velocity.
2690subroutine ice_shelf_solve_inner_cr(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, &
2691 IDIAGu, IDIAGv, H_node, float_cond, hmask, &
2692 rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, &
2693 Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv)
2694 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
2695 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
2696 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
2697 real, dimension(SZDIB_(G),SZDJB_(G)), &
2698 intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]
2699 real, dimension(SZDIB_(G),SZDJB_(G)), &
2700 intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]
2701 real, dimension(SZDIB_(G),SZDJB_(G)), &
2702 intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2]
2703 real, dimension(SZDIB_(G),SZDJB_(G)), &
2704 intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2]
2705 real, dimension(SZDIB_(G),SZDJB_(G)), &
2706 intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2]
2707 real, dimension(SZDIB_(G),SZDJB_(G)), &
2708 intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2]
2709 real, dimension(SZDIB_(G),SZDJB_(G)), &
2710 intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s]
2711 real, dimension(SZDIB_(G),SZDJB_(G)), &
2712 intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s]
2713 real, dimension(SZDIB_(G),SZDJB_(G)), &
2714 intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m]
2715 real, dimension(SZDI_(G),SZDJ_(G)), &
2716 intent(in) :: float_cond !< Grounding line indicator [nondim]
2717 real, dimension(SZDI_(G),SZDJ_(G)), &
2718 intent(in) :: hmask !< Ice shelf coverage mask
2719 real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim]
2720 real, intent(in) :: resid_scale !< Scaling for inner products
2721 !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1]
2722 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
2723 intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1]
2724 real, dimension(:,:,:,:,:,:), &
2725 intent(in) :: Phisub !< Subgridscale quadrature weights [nondim]
2726 integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not
2727 integer, intent(out) :: iters !< The number of iterations used
2728 integer, intent(in) :: Is_sum !< Starting i-index for global sums
2729 integer, intent(in) :: Js_sum !< Starting j-index for global sums
2730 integer, intent(in) :: Ie_sum !< Ending i-index for global sums
2731 integer, intent(in) :: Je_sum !< Ending j-index for global sums
2732 integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays
2733 integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays
2734
2735 real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction
2736 !! at quadrature points [L T-1 ~> m s-1]
2737 real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction
2738 !! at quadrature points [L T-1 ~> m s-1]
2739 real, dimension(SZDIB_(G),SZDJB_(G)) :: &
2740 Ru, Rv, & ! Residuals (r) [R L3 Z T-2 ~> m kg s-2]
2741 Zu, Zv, & ! Preconditioned residuals (z = M^-1 r) [L T-1 ~> m s-1]
2742 Du, Dv, & ! Search directions (p) [L T-1 ~> m s-1]
2743 Qu, Qv ! A * p [R L3 Z T-2 ~> m kg s-2]
2744 real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Pointwise products for global sums.
2745 ! sum_vec_3d(:,:,1): r^2 [kg2 m2 s-4] or z·q [kg m2 s-3] (context-dependent)
2746 ! sum_vec_3d(:,:,2): z·w or q·(M^-1 q) [kg m2 s-3]
2747 real :: alpha ! Step length [nondim]
2748 real :: beta ! Direction update coefficient [nondim]
2749 real :: r_norm_sq ! Squared residual norm [kg2 m2 s-4]
2750 real :: z_w_sum ! Inner product (z_k, A z_k); beta denominator [kg m2 s-3]
2751 real :: z_w_sum_new ! Inner product (z_{k+1}, A z_{k+1}); beta numerator [kg m2 s-3]
2752 real :: z_q_sum ! Inner product (z_k, A p_k); alpha numerator [kg m2 s-3]
2753 real :: q_s_sum ! Inner product (A p_k, M^-1 A p_k); alpha denom [kg m2 s-3]
2754 real :: resid0tol2 ! Convergence threshold: tol^2 * ||r_0||^2 [kg2 m2 s-4]
2755 real :: sv3dsum ! Unused scalar return from reproducing_sum [various]
2756 real :: sv3dsums(2) ! Component sums from reproducing_sum
2757 ! sv3dsums(1): r^2 or z·q [kg2 m2 s-4 or kg m2 s-3] (context-dependent)
2758 ! sv3dsums(2): z·w or q·M^-1 q [kg m2 s-3]
2759 real :: resid2_scale ! Scaling for squared-stress inner products [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1]
2760 integer :: iter, i, j, isc, iec, jsc, jec
2761 integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq
2762
2763 isdq = g%IsdB ; iedq = g%IedB ; jsdq = g%JsdB ; jedq = g%JedB
2764 iscq = g%IscB ; iecq = g%IecB ; jscq = g%JscB ; jecq = g%JecB
2765 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
2766
2767 resid2_scale = ((us%RZ_to_kg_m2*us%L_to_m)*us%L_T_to_m_s**2)**2
2768
2769 ! Initialize CR-specific arrays
2770 ru(:,:) = 0 ; rv(:,:) = 0 ; zu(:,:) = 0 ; zv(:,:) = 0
2771 du(:,:) = 0 ; dv(:,:) = 0 ; qu(:,:) = 0 ; qv(:,:) = 0
2772
2773 ! r_0 = b - A*x_0
2774 ru(:,:) = (rhsu(:,:) - au(:,:)) ; rv(:,:) = (rhsv(:,:) - av(:,:))
2775
2776 ! current velocities used in CG_action for basal drag
2777 u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:)
2778
2779 ! z_0 = M^-1 r_0
2780 do j=jsdq,jedq ; do i=isdq,iedq
2781 if (cs%umask(i,j) == 1) zu(i,j) = ru(i,j) * idiagu(i,j)
2782 if (cs%vmask(i,j) == 1) zv(i,j) = rv(i,j) * idiagv(i,j)
2783 enddo ; enddo
2784
2785 ! p_0 = z_0
2786 du(:,:) = zu(:,:) ; dv(:,:) = zv(:,:)
2787
2788 ! Compute A * z_0
2789 au(:,:) = 0 ; av(:,:) = 0
2790 call cg_action(cs, au, av, zu, zv, phi, phisub, cs%umask, cs%vmask, hmask, &
2791 h_node, cs%ice_visc, float_cond, cs%bed_elev, u_curr, v_curr, &
2792 g, us, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow)
2793 call pass_vector(au, av, g%domain, to_all, bgrid_ne)
2794
2795 ! q_0 = A * p_0
2796 qu(:,:) = au(:,:) ; qv(:,:) = av(:,:)
2797
2798 ! Initial Norms
2799 sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0
2800 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2801 if (cs%umask(i,j) == 1) then
2802 sum_vec_3d(i,j,1) = resid2_scale * ru(i,j)**2
2803 sum_vec_3d(i,j,2) = resid_scale * (zu(i,j) * au(i,j))
2804 endif
2805 if (cs%vmask(i,j) == 1) then
2806 sum_vec_3d(i,j,1) = sum_vec_3d(i,j,1) + resid2_scale * rv(i,j)**2
2807 sum_vec_3d(i,j,2) = sum_vec_3d(i,j,2) + resid_scale * (zv(i,j) * av(i,j))
2808 endif
2809 enddo ; enddo
2810 sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), is_sum, ie_sum, js_sum, je_sum, sums=sv3dsums(1:2) )
2811
2812 r_norm_sq = sv3dsums(1)
2813 z_w_sum = sv3dsums(2)
2814
2815 resid0tol2 = cs%cg_tol_current**2 * r_norm_sq
2816 conv_flag = 0
2817
2818 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2819 !! !!
2820 !! MAIN CONJUGATE RESIDUAL LOOP !!
2821 !! !!
2822 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2823
2824 do iter = 1, cs%cg_max_iterations
2825
2826 ! --- STEP 1: alpha = (z_k, q_k) / (q_k, M^-1 q_k) ---
2827 sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0
2828 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2829 if (cs%umask(i,j) == 1) then
2830 sum_vec_3d(i,j,1) = resid_scale * (zu(i,j) * qu(i,j))
2831 ! Order matters to prevent float overflow: Q * (Q * IDiag)
2832 sum_vec_3d(i,j,2) = resid_scale * (qu(i,j) * (qu(i,j) * idiagu(i,j)))
2833 endif
2834 if (cs%vmask(i,j) == 1) then
2835 sum_vec_3d(i,j,1) = sum_vec_3d(i,j,1) + resid_scale * (zv(i,j) * qv(i,j))
2836 sum_vec_3d(i,j,2) = sum_vec_3d(i,j,2) + resid_scale * (qv(i,j) * (qv(i,j) * idiagv(i,j)))
2837 endif
2838 enddo ; enddo
2839 sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), is_sum, ie_sum, js_sum, je_sum, sums=sv3dsums(1:2) )
2840
2841 z_q_sum = sv3dsums(1)
2842 q_s_sum = sv3dsums(2)
2843
2844 if (q_s_sum == 0.0) then
2845 iters = iter
2846 conv_flag = 1
2847 exit
2848 endif
2849 alpha = z_q_sum / q_s_sum
2850
2851 ! --- STEP 2: Update x, r, and z (Fused over Full Domain) ---
2852 ! Zu halos are populated here since the loop covers Jsdq..Jedq; no pass_vector needed.
2853 do j=jsdq,jedq ; do i=isdq,iedq
2854 if (cs%umask(i,j) == 1) then
2855 u_shlf(i,j) = u_shlf(i,j) + alpha * du(i,j)
2856 ru(i,j) = ru(i,j) - alpha * qu(i,j)
2857 zu(i,j) = ru(i,j) * idiagu(i,j)
2858 endif
2859 if (cs%vmask(i,j) == 1) then
2860 v_shlf(i,j) = v_shlf(i,j) + alpha * dv(i,j)
2861 rv(i,j) = rv(i,j) - alpha * qv(i,j)
2862 zv(i,j) = rv(i,j) * idiagv(i,j)
2863 endif
2864 enddo ; enddo
2865
2866 ! --- STEP 3: w_{k+1} = A z_{k+1} ---
2867 au(:,:) = 0 ; av(:,:) = 0
2868 call cg_action(cs, au, av, zu, zv, phi, phisub, cs%umask, cs%vmask, hmask, &
2869 h_node, cs%ice_visc, float_cond, cs%bed_elev, u_curr, v_curr, &
2870 g, us, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow)
2871 call pass_vector(au, av, g%domain, to_all, bgrid_ne)
2872
2873 ! --- STEP 4: beta and convergence check ---
2874 sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0
2875 do j=jscq_sv,jecq ; do i=iscq_sv,iecq
2876 if (cs%umask(i,j) == 1) then
2877 sum_vec_3d(i,j,1) = resid2_scale * ru(i,j)**2
2878 sum_vec_3d(i,j,2) = resid_scale * (zu(i,j) * au(i,j))
2879 endif
2880 if (cs%vmask(i,j) == 1) then
2881 sum_vec_3d(i,j,1) = sum_vec_3d(i,j,1) + resid2_scale * rv(i,j)**2
2882 sum_vec_3d(i,j,2) = sum_vec_3d(i,j,2) + resid_scale * (zv(i,j) * av(i,j))
2883 endif
2884 enddo ; enddo
2885 sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), is_sum, ie_sum, js_sum, je_sum, sums=sv3dsums(1:2) )
2886
2887 r_norm_sq = sv3dsums(1)
2888 z_w_sum_new = sv3dsums(2)
2889
2890 if (r_norm_sq <= resid0tol2 .or. z_w_sum==0.0) then
2891 iters = iter
2892 conv_flag = 1
2893 exit
2894 endif
2895
2896 beta = z_w_sum_new / z_w_sum
2897 z_w_sum = z_w_sum_new
2898
2899 ! --- STEP 5: Update p and q ---
2900 do j=jsdq,jedq ; do i=isdq,iedq
2901 if (cs%umask(i,j) == 1) then
2902 du(i,j) = zu(i,j) + beta * du(i,j)
2903 qu(i,j) = au(i,j) + beta * qu(i,j)
2904 endif
2905 if (cs%vmask(i,j) == 1) then
2906 dv(i,j) = zv(i,j) + beta * dv(i,j)
2907 qv(i,j) = av(i,j) + beta * qv(i,j)
2908 endif
2909 enddo ; enddo
2910
2911 enddo ! end of CR loop
2912
2913end subroutine ice_shelf_solve_inner_cr
2914
2915subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice)
2916 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
2917 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
2918 type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure.
2919 real, intent(in) :: time_step !< The time step for this update [T ~> s].
2920 real, dimension(SZDI_(G),SZDJ_(G)), &
2921 intent(inout) :: hmask !< A mask indicating which tracer points are
2922 !! partly or fully covered by an ice-shelf
2923 real, dimension(SZDI_(G),SZDJ_(G)), &
2924 intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m].
2925 real, dimension(SZDI_(G),SZDJ_(G)), &
2926 intent(inout) :: h_after_uflux !< The ice shelf thicknesses after
2927 !! the zonal mass fluxes [Z ~> m].
2928 real, dimension(SZDIB_(G),SZDJ_(G)), &
2929 intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3]
2930
2931 ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells
2932 ! if there is an input bdry condition, the thickness there will be set in initialization
2933
2934
2935 integer :: i, j
2936 integer :: ish, ieh, jsh, jeh
2937 real :: u_face ! Zonal velocity at a face [L T-1 ~> m s-1]
2938 real :: h_face ! Thickness at a face for transport [Z ~> m]
2939 real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim]
2940
2941! is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec
2942! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
2943
2944 ish = lb%ish ; ieh = lb%ieh ; jsh = lb%jsh ; jeh = lb%jeh
2945
2946 ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition
2947 ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC
2948
2949 do j=jsh,jeh ; do i=ish-1,ieh
2950 if (cs%u_face_mask(i,j) == 4.) then ! The flux itself is a specified boundary condition.
2951 uh_ice(i,j) = (time_step * g%dyCu(i,j)) * cs%u_flux_bdry_val(i,j)
2952 elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then
2953 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
2954 h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered.
2955
2956 if (u_face > 0) then
2957 if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west
2958 h_face = cs%h_bdry_val(i,j)
2959 elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face.
2960 if ((hmask(i-1,j) == 1 .or. hmask(i-1,j) == 3) .and. &
2961 (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then
2962 slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j))
2963 ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here.
2964 h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i+1,j)))
2965 else
2966 h_face = h0(i,j)
2967 endif
2968 endif
2969 else
2970 if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east
2971 h_face = cs%h_bdry_val(i+1,j)
2972 elseif (hmask(i+1,j) == 1) then
2973 if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. &
2974 (hmask(i+2,j) == 1 .or. hmask(i+2,j) == 3)) then
2975 slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j))
2976 h_face = h0(i+1,j) - slope_lim * (0.5 * (h0(i+2,j)-h0(i+1,j)))
2977 else
2978 h_face = h0(i+1,j)
2979 endif
2980 endif
2981 endif
2982
2983 uh_ice(i,j) = (time_step * g%dyCu(i,j)) * (u_face * h_face)
2984 else
2985 uh_ice(i,j) = 0.0
2986 endif
2987 enddo ; enddo
2988
2989 do j=jsh,jeh ; do i=ish,ieh
2990 if (hmask(i,j) /= 3) &
2991 h_after_uflux(i,j) = h0(i,j) + (uh_ice(i-1,j) - uh_ice(i,j)) * g%IareaT(i,j)
2992
2993 ! Update the masks of cells that have gone from no ice to partial ice.
2994 if ((hmask(i,j) == 0) .and. ((uh_ice(i-1,j) > 0.0) .or. (uh_ice(i,j) < 0.0))) hmask(i,j) = 2
2995 enddo ; enddo
2996
2997end subroutine ice_shelf_advect_thickness_x
2998
2999subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after_vflux, vh_ice)
3000 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
3001 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
3002 type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure.
3003 real, intent(in) :: time_step !< The time step for this update [T ~> s].
3004 real, dimension(SZDI_(G),SZDJ_(G)), &
3005 intent(inout) :: hmask !< A mask indicating which tracer points are
3006 !! partly or fully covered by an ice-shelf
3007 real, dimension(SZDI_(G),SZDJ_(G)), &
3008 intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m].
3009 real, dimension(SZDI_(G),SZDJ_(G)), &
3010 intent(inout) :: h_after_vflux !< The ice shelf thicknesses after
3011 !! the meridional mass fluxes [Z ~> m].
3012 real, dimension(SZDI_(G),SZDJB_(G)), &
3013 intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3]
3014
3015 ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells
3016 ! if there is an input bdry condition, the thickness there will be set in initialization
3017
3018
3019 integer :: i, j
3020 integer :: ish, ieh, jsh, jeh
3021 real :: v_face ! Pseudo-meridional velocity at a face [L T-1 ~> m s-1]
3022 real :: h_face ! Thickness at a face for transport [Z ~> m]
3023 real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim]
3024
3025 ish = lb%ish ; ieh = lb%ieh ; jsh = lb%jsh ; jeh = lb%jeh
3026
3027 ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition
3028 ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC
3029
3030 do j=jsh-1,jeh ; do i=ish,ieh
3031 if (cs%v_face_mask(i,j) == 4.) then ! The flux itself is a specified boundary condition.
3032 vh_ice(i,j) = (time_step * g%dxCv(i,j)) * cs%v_flux_bdry_val(i,j)
3033 elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then
3034 v_face = 0.5 * (cs%v_shelf(i-1,j) + cs%v_shelf(i,j))
3035 h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered.
3036
3037 if (v_face > 0) then
3038 if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south
3039 h_face = cs%h_bdry_val(i,j)
3040 elseif (hmask(i,j) == 1) then ! There can be northward flow through this face.
3041 if ((hmask(i,j-1) == 1 .or. hmask(i,j-1) == 3) .and. &
3042 (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then
3043 slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j))
3044 ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here.
3045 h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i,j+1)))
3046 else
3047 h_face = h0(i,j)
3048 endif
3049 endif
3050 else
3051 if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north
3052 h_face = cs%h_bdry_val(i,j+1)
3053 elseif (hmask(i,j+1) == 1) then
3054 if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. &
3055 (hmask(i,j+2) == 1 .or. hmask(i,j+2) == 3)) then
3056 slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1))
3057 h_face = h0(i,j+1) - slope_lim * (0.5 * (h0(i,j+2)-h0(i,j+1)))
3058 else
3059 h_face = h0(i,j+1)
3060 endif
3061 endif
3062 endif
3063
3064 vh_ice(i,j) = (time_step * g%dxCv(i,j)) * (v_face * h_face)
3065 else
3066 vh_ice(i,j) = 0.0
3067 endif
3068 enddo ; enddo
3069
3070 do j=jsh,jeh ; do i=ish,ieh
3071 if (hmask(i,j) /= 3) &
3072 h_after_vflux(i,j) = h0(i,j) + (vh_ice(i,j-1) - vh_ice(i,j)) * g%IareaT(i,j)
3073
3074 ! Update the masks of cells that have gone from no ice to partial ice.
3075 if ((hmask(i,j) == 0) .and. ((vh_ice(i,j-1) > 0.0) .or. (vh_ice(i,j) < 0.0))) hmask(i,j) = 2
3076 enddo ; enddo
3077
3078end subroutine ice_shelf_advect_thickness_y
3079
3080subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice)
3081 type(ice_shelf_dyn_cs), intent(in) :: cs !< A pointer to the ice shelf control structure
3082 type(ice_shelf_state), intent(inout) :: iss !< A structure with elements that describe
3083 !! the ice-shelf state
3084 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
3085 real, dimension(SZDI_(G),SZDJ_(G)), &
3086 intent(inout) :: hmask !< A mask indicating which tracer points are
3087 !! partly or fully covered by an ice-shelf
3088 real, dimension(SZDIB_(G),SZDJ_(G)), &
3089 intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3]
3090 real, dimension(SZDI_(G),SZDJB_(G)), &
3091 intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3]
3092
3093 ! in this subroutine we go through the computational cells only and, if they are empty or partial cells,
3094 ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary
3095
3096 ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly,
3097 ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells.
3098 ! (it is highly unlikely there will not be any; in which case this will need to be rethought.)
3099
3100 ! most likely there will only be one "overflow". If not, though, a pass_var of all relevant variables
3101 ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through
3102 ! many iterations
3103
3104 ! when 3d advected scalars are introduced, they will be impacted by what is done here
3105
3106 ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary
3107 !
3108 ! from eastern neighbor: flux_enter(:,:,1)
3109 ! from western neighbor: flux_enter(:,:,2)
3110 ! from southern neighbor: flux_enter(:,:,3)
3111 ! from northern neighbor: flux_enter(:,:,4)
3112 !
3113 ! o--- (4) ---o
3114 ! | |
3115 ! (1) (2)
3116 ! | |
3117 ! o--- (3) ---o
3118 !
3119
3120 integer :: i, j, isc, iec, jsc, jec, n_flux, k, iter_count
3121 integer :: i_off, j_off
3122 integer :: iter_flag
3123
3124 real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m]
3125 real :: h_reference_ew !contribution to reference thickness from east + west cells [Z ~> m]
3126 real :: h_reference_ns !contribution to reference thickness from north + south cells [Z ~> m]
3127 real :: tot_flux ! The total ice mass flux [Z L2 ~> m3]
3128 real :: tot_flux_ew ! The contribution to total ice mass flux from east + west cells [Z L2 ~> m3]
3129 real :: tot_flux_ns ! The contribution to total ice mass flux from north + south cells [Z L2 ~> m3]
3130 real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3]
3131 real :: dxdyh ! Cell area [L2 ~> m2]
3132 character(len=160) :: mesg ! The text of an error message
3133 integer, dimension(4) :: mapi, mapj, new_partial
3134 real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the
3135 ! cell through the 4 cell boundaries [Z L2 ~> m3].
3136 real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the
3137 ! cell through the 4 cell boundaries [Z L2 ~> m3].
3138
3139 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
3140 i_off = g%idg_offset ; j_off = g%jdg_offset
3141 iter_count = 0 ; iter_flag = 1
3142
3143 flux_enter(:,:,:) = 0.0
3144 do j=jsc-1,jec+1 ; do i=isc-1,iec+1
3145 if ((hmask(i,j) == 0) .or. (hmask(i,j) == 2)) then
3146 flux_enter(i,j,1) = max(uh_ice(i-1,j), 0.0)
3147 flux_enter(i,j,2) = max(-uh_ice(i,j), 0.0)
3148 flux_enter(i,j,3) = max(vh_ice(i,j-1), 0.0)
3149 flux_enter(i,j,4) = max(-vh_ice(i,j), 0.0)
3150 endif
3151 enddo ; enddo
3152
3153 mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0
3154 mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0
3155
3156 do while (iter_flag == 1)
3157
3158 iter_flag = 0
3159
3160 if (iter_count > 0) then
3161 flux_enter(:,:,:) = flux_enter_replace(:,:,:)
3162 endif
3163 flux_enter_replace(:,:,:) = 0.0
3164
3165 iter_count = iter_count + 1
3166
3167 ! if iter_count >= 3 then some halo updates need to be done...
3168 if (iter_count==3) then
3169 call mom_error(fatal, "MOM_ice_shelf_dyn.F90, shelf_advance_front iter >=3.")
3170 endif
3171
3172 do j=jsc-1,jec+1
3173
3174 if (cs%reentrant_y .OR. (((j+j_off) <= g%domain%njglobal) .AND. &
3175 ((j+j_off) >= 1))) then
3176
3177 do i=isc-1,iec+1
3178
3179 if (cs%reentrant_x .OR. (((i+i_off) <= g%domain%niglobal) .AND. &
3180 ((i+i_off) >= 1))) then
3181 ! first get reference thickness by averaging over cells that are fluxing into this cell
3182 n_flux = 0
3183 h_reference_ew = 0.0
3184 h_reference_ns = 0.0
3185 tot_flux_ew = 0.0
3186 tot_flux_ns = 0.0
3187
3188 do k=1,2
3189 if (flux_enter(i,j,k) > 0) then
3190 n_flux = n_flux + 1
3191 h_reference_ew = h_reference_ew + flux_enter(i,j,k) * iss%h_shelf(i+2*k-3,j)
3192 !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j)
3193 tot_flux_ew = tot_flux_ew + flux_enter(i,j,k)
3194 flux_enter(i,j,k) = 0.0
3195 endif
3196 enddo
3197
3198 do k=1,2
3199 if (flux_enter(i,j,k+2) > 0) then
3200 n_flux = n_flux + 1
3201 h_reference_ns = h_reference_ns + flux_enter(i,j,k+2) * iss%h_shelf(i,j+2*k-3)
3202 !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3)
3203 tot_flux_ns = tot_flux_ns + flux_enter(i,j,k+2)
3204 flux_enter(i,j,k+2) = 0.0
3205 endif
3206 enddo
3207
3208 h_reference = h_reference_ew + h_reference_ns
3209 tot_flux = tot_flux_ew + tot_flux_ns
3210
3211 if (n_flux > 0) then
3212 dxdyh = g%areaT(i,j)
3213 h_reference = h_reference / tot_flux
3214 !h_reference = h_reference / real(n_flux)
3215 partial_vol = iss%h_shelf(i,j) * iss%area_shelf_h(i,j) + tot_flux
3216
3217 if ((partial_vol / g%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow
3218 if (iss%hmask(i,j)/=3) iss%hmask(i,j) = 1
3219 iss%h_shelf(i,j) = h_reference
3220 iss%area_shelf_h(i,j) = g%areaT(i,j)
3221 elseif ((partial_vol / g%areaT(i,j)) < h_reference) then
3222 iss%hmask(i,j) = 2
3223 ! ISS%mass_shelf(i,j) = partial_vol * CS%density_ice
3224 iss%area_shelf_h(i,j) = partial_vol / h_reference
3225 iss%h_shelf(i,j) = h_reference
3226 else
3227
3228 if (iss%hmask(i,j)/=3) iss%hmask(i,j) = 1
3229 iss%area_shelf_h(i,j) = g%areaT(i,j)
3230 !h_temp(i,j) = h_reference
3231 partial_vol = partial_vol - h_reference * g%areaT(i,j)
3232
3233 iter_flag = 1
3234
3235 n_flux = 0 ; new_partial(:) = 0
3236
3237 do k=1,2
3238 if (cs%u_face_mask(i-2+k,j) == 2) then
3239 n_flux = n_flux + 1
3240 elseif (iss%hmask(i+2*k-3,j) == 0) then
3241 n_flux = n_flux + 1
3242 new_partial(k) = 1
3243 endif
3244 if (cs%v_face_mask(i,j-2+k) == 2) then
3245 n_flux = n_flux + 1
3246 elseif (iss%hmask(i,j+2*k-3) == 0) then
3247 n_flux = n_flux + 1
3248 new_partial(k+2) = 1
3249 endif
3250 enddo
3251
3252 if (n_flux == 0) then ! there is nowhere to put the extra ice!
3253 iss%h_shelf(i,j) = h_reference + partial_vol / g%areaT(i,j)
3254 else
3255 iss%h_shelf(i,j) = h_reference
3256
3257 do k=1,2
3258 if (new_partial(k) == 1) &
3259 flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux)
3260 if (new_partial(k+2) == 1) &
3261 flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux)
3262 enddo
3263 endif
3264
3265 endif ! Parital_vol test.
3266 endif ! n_flux gt 0 test.
3267
3268 endif
3269 enddo ! j-loop
3270 endif
3271 enddo
3272
3273 ! call max_across_PEs(iter_flag)
3274
3275 enddo ! End of do while(iter_flag) loop
3276
3277 call max_across_pes(iter_count)
3278
3279 if (is_root_pe() .and. (iter_count > 1)) then
3280 write(mesg,*) "shelf_advance_front: ", iter_count, " max iterations"
3281 call mom_mesg(mesg, 5)
3282 endif
3283
3284end subroutine shelf_advance_front
3285
3286!> Apply a very simple calving law using a minimum thickness rule
3287subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve, halo)
3288 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
3289 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m].
3290 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by
3291 !! the ice shelf [L2 ~> m2].
3292 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask !< A mask indicating which tracer points are
3293 !! partly or fully covered by an ice-shelf
3294 real, intent(in) :: thickness_calve !< The thickness at which to trigger calving [Z ~> m].
3295 integer, optional, intent(in) :: halo !< The number of halo points to use. If not present,
3296 !! work on the entire data domain.
3297 integer :: i, j, is, ie, js, je
3298
3299 if (present(halo)) then
3300 is = g%isc - halo ; ie = g%iec + halo ; js = g%jsc - halo ; je = g%jec + halo
3301 else
3302 is = g%isd ; ie = g%ied ; js = g%jsd ; je = g%jed
3303 endif
3304
3305 do j=js,je ; do i=is,ie
3306! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. &
3307! (CS%ground_frac(i,j) == 0.0)) then
3308 if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then
3309 h_shelf(i,j) = 0.0
3310 area_shelf_h(i,j) = 0.0
3311 hmask(i,j) = 0.0
3312 endif
3313 enddo ; enddo
3314
3315end subroutine ice_shelf_min_thickness_calve
3316
3317subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask)
3318 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
3319 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m].
3320 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by
3321 !! the ice shelf [L2 ~> m2].
3322 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask !< A mask indicating which tracer points are
3323 !! partly or fully covered by an ice-shelf
3324 real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: calve_mask !< A mask that indicates where the ice
3325 !! shelf can exist, and where it will calve.
3326
3327 integer :: i, j
3328
3329 do j=g%jsc,g%jec ; do i=g%isc,g%iec
3330 if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then
3331 h_shelf(i,j) = 0.0
3332 area_shelf_h(i,j) = 0.0
3333 hmask(i,j) = 0.0
3334 endif
3335 enddo ; enddo
3336
3337end subroutine calve_to_mask
3338
3339!> Calculate driving stress using cell-centered bed elevation and ice thickness
3340subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD)
3341 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
3342 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
3343 !! the ice-shelf state
3344 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
3345 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
3346 real, dimension(SZDI_(G),SZDJ_(G)), &
3347 intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m].
3348 real, dimension(SZDIB_(G),SZDJB_(G)), &
3349 intent(inout) :: taudx !< X-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2]
3350 real, dimension(SZDIB_(G),SZDJB_(G)), &
3351 intent(inout) :: taudy !< Y-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2]
3352
3353
3354! driving stress!
3355
3356! ! taudx and taudy will hold driving stress in the x- and y- directions when done.
3357! they will sit on the BGrid, and so their size depends on whether the grid is symmetric
3358!
3359! Since this is a finite element solve, they will actually have the form \int \Phi_i rho g h \nabla s
3360!
3361! OD -this is important and we do not yet know where (in MOM) it will come from. It represents
3362! "average" ocean depth -- and is needed to find surface elevation
3363! (it is assumed that base_ice = bed + OD)
3364
3365 real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m].
3366 real, dimension(SZDI_(G),SZDJ_(G)) :: sx_e, sy_e !element contributions to driving stress
3367 real :: rho, rhow ! Ice and ocean densities [R ~> kg m-3]
3368 real :: sx, sy ! Ice shelf top slopes at tracer points [Z L-1 ~> nondim]
3369 real :: neumann_val ! [R Z L2 T-2 ~> kg s-2]
3370 real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]
3371 real :: scale ! Scaling factor used to ensure surface slope magnitude does not exceed CS%max_surface_slope
3372 logical :: valid_N, valid_S, valid_E, valid_W
3373 integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq
3374 integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec
3375 integer :: i_off, j_off
3376
3377 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
3378! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB
3379 isd = g%isd ; jsd = g%jsd ; ied = g%ied ; jed = g%jed
3380! iegq = G%iegB ; jegq = G%jegB
3381! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1
3382 gisc = 1 ; gjsc = 1
3383! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo
3384 giec = g%domain%niglobal ; gjec = g%domain%njglobal
3385! is = iscq - 1 ; js = jscq - 1
3386 i_off = g%idg_offset ; j_off = g%jdg_offset
3387
3388
3389 rho = cs%density_ice
3390 rhow = cs%density_ocean_avg
3391 grav = cs%g_Earth
3392 ! prelim - go through and calculate S
3393
3394 if (cs%GL_couple) then
3395 do j=jsc-2,jec+2 ; do i=isc-2,iec+2
3396 s(i,j) = -cs%bed_elev(i,j) + (od(i,j) + max(iss%h_shelf(i,j),cs%min_h_shelf))
3397 enddo ; enddo
3398 else
3399 ! check whether the ice is floating or grounded
3400 do j=jsc-2,jec+2 ; do i=isc-2,iec+2
3401 if (cs%rhoi_rhow * max(iss%h_shelf(i,j),cs%min_h_shelf) - cs%bed_elev(i,j) <= 0) then
3402 s(i,j) = (1 - cs%rhoi_rhow)*max(iss%h_shelf(i,j),cs%min_h_shelf)
3403 else
3404 s(i,j) = max(iss%h_shelf(i,j),cs%min_h_shelf)-cs%bed_elev(i,j)
3405 endif
3406 enddo ; enddo
3407 endif
3408
3409 call pass_var(s, g%domain)
3410
3411 do j=jsc-1,jec+1
3412 do i=isc-1,iec+1
3413
3414 if (iss%hmask(i,j) == 1 .or. iss%hmask(i,j) == 3) then
3415 ! we are inside the global computational bdry, at an ice-filled cell
3416
3417 ! Calculate the x-direction surface slope at tracer points.
3418 sx = 0.0
3419 valid_e = (iss%hmask(i+1,j) == 1 .or. iss%hmask(i+1,j) == 3)
3420 valid_w = (iss%hmask(i-1,j) == 1 .or. iss%hmask(i-1,j) == 3)
3421 if (cs%shelf_top_slope_bugs) then
3422 if (((i+i_off) == gisc) .and. (.not.cs%reentrant_x)) then ! at west computational bdry
3423 if (valid_e) sx = (s(i+1,j)-s(i,j)) / g%dxT(i,j)
3424 elseif (((i+i_off) == giec) .and. (.not.cs%reentrant_x)) then ! at east computational bdry
3425 if (valid_w) sx = (s(i,j)-s(i-1,j)) / g%dxT(i,j)
3426 elseif (valid_e .and. valid_w) then
3427 ! This is the usual interior point
3428 sx = (s(i+1,j) - s(i-1,j)) / (g%dxT(i,j) + g%dxT(i-1,j))
3429 elseif (valid_e) then
3430 sx = (s(i+1,j) - s(i,j)) / (g%dxT(i,j) + g%dxT(i+1,j))
3431 elseif (valid_w) then
3432 sx = (s(i,j) - s(i-1,j)) / (g%dxT(i,j) + g%dxT(i-1,j))
3433 endif
3434 else ! Correct the bugs in the version above.
3435 if (((i+i_off) == gisc) .and. (.not.cs%reentrant_x)) then ! at west computational bdry
3436 if (valid_e) sx = (s(i+1,j) - s(i,j)) * g%IdxCu(i,j)
3437 elseif (((i+i_off) == giec) .and. (.not.cs%reentrant_x)) then ! at east computational bdry
3438 if (valid_w) sx = (s(i,j) - s(i-1,j)) * g%IdxCu(i-1,j)
3439 elseif (valid_e .and. valid_w) then
3440 ! This is the usual interior point
3441 sx = 0.5*(s(i+1,j) - s(i-1,j)) * g%IdxT(i,j)
3442 elseif (valid_e) then ! Use a one-sided estimate from the east.
3443 sx = (s(i+1,j) - s(i,j)) * g%IdxCu(i,j)
3444 elseif (valid_w) then ! Use a one-sided estimate from the west.
3445 sx = (s(i,j) - s(i-1,j)) * g%IdxCu(i-1,j)
3446 endif
3447 endif
3448
3449 ! Calculate the y-direction surface slope at tracer points.
3450 sy = 0.0
3451 valid_n = (iss%hmask(i,j+1) == 1 .or. iss%hmask(i,j+1) == 3)
3452 valid_s = (iss%hmask(i,j-1) == 1 .or. iss%hmask(i,j-1) == 3)
3453 if (cs%shelf_top_slope_bugs) then
3454 if (((j+j_off) == gjsc) .and. (.not. cs%reentrant_y)) then ! at south computational bdry
3455 if (valid_n) sy = (s(i,j+1)-s(i,j)) / g%dyT(i,j)
3456 elseif (((j+j_off) == gjec) .and. (.not. cs%reentrant_y)) then ! at north computational bdry
3457 if (valid_s) sy = (s(i,j)-s(i,j-1)) / g%dyT(i,j)
3458 elseif (valid_n .and. valid_s) then
3459 ! This is the usual interior point
3460 sy = (s(i,j+1) - s(i,j-1)) / (g%dyT(i,j) + g%dyT(i,j-1))
3461 elseif (valid_n) then
3462 sy = (s(i,j+1) - s(i,j)) / (g%dyT(i,j) + g%dyT(i,j+1))
3463 elseif (valid_s) then
3464 sy = (s(i,j) - s(i,j-1)) / (g%dyT(i,j) + g%dyT(i,j-1))
3465 endif
3466 else ! Correct the bugs in the version above.
3467 if (((j+j_off) == gjsc) .and. (.not. cs%reentrant_y)) then ! at south computational bdry
3468 if (valid_n) sy = (s(i,j+1) - s(i,j)) * g%IdyCv(i,j)
3469 elseif (((j+j_off) == gjec) .and. (.not. cs%reentrant_y)) then ! at north computational bdry
3470 if (valid_s) sy = (s(i,j) - s(i,j-1)) * g%IdyCv(i,j-1)
3471 elseif (valid_n .and. valid_s) then
3472 ! This is the usual interior point
3473 sy = 0.5*(s(i,j+1) - s(i,j-1)) * g%IdyT(i,j)
3474 elseif (valid_n) then ! Use a one-sided estimate from the north.
3475 sy = (s(i,j+1) - s(i,j)) * g%IdyCv(i,j)
3476 elseif (valid_s) then ! Use a one-sided estimate from the south.
3477 sy = (s(i,j) - s(i,j-1)) * g%IdyCv(i,j-1)
3478 endif
3479 endif
3480
3481 if (cs%max_surface_slope>0) then
3482 scale = cs%max_surface_slope / max( sqrt((sx**2) + (sy**2)), cs%max_surface_slope )
3483 sx = scale*sx ; sy = scale*sy
3484 endif
3485
3486 sx_e(i,j) = (-.25 * g%areaT(i,j)) * ((rho * grav) * (max(iss%h_shelf(i,j),cs%min_h_shelf) * sx))
3487 sy_e(i,j) = (-.25 * g%areaT(i,j)) * ((rho * grav) * (max(iss%h_shelf(i,j),cs%min_h_shelf) * sy))
3488
3489 cs%sx_shelf(i,j) = sx ; cs%sy_shelf(i,j) = sy
3490
3491 !Stress (Neumann) boundary conditions
3492 if (cs%ground_frac(i,j) == 1) then
3493 neumann_val = ((.5 * grav) * (rho * max(iss%h_shelf(i,j),cs%min_h_shelf)**2 - &
3494 rhow * max(0.0, cs%bed_elev(i,j))**2))
3495 else
3496 neumann_val = (.5 * grav) * ((1-cs%rhoi_rhow) * (rho * max(iss%h_shelf(i,j),cs%min_h_shelf)**2))
3497 endif
3498 if ((cs%u_face_mask_bdry(i-1,j) == 2) .OR. &
3499 ((iss%hmask(i-1,j) == 0 .OR. iss%hmask(i-1,j) == 2) .AND. (cs%reentrant_x .OR. (i+i_off /= gisc)))) then
3500 ! left face of the cell is at a stress boundary
3501 ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated
3502 ! pressure on either side of the face
3503 ! on the ice side, it is rho g h^2 / 2
3504 ! on the ocean side, it is rhow g (delta OD)^2 / 2
3505 ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation
3506 ! is not above the base of the ice in the current cell
3507
3508 ! Note the negative sign due to the direction of the normal vector
3509 taudx(i-1,j-1) = taudx(i-1,j-1) - .5 * g%dyCu(i-1,j) * neumann_val
3510 taudx(i-1,j) = taudx(i-1,j) - .5 * g%dyCu(i-1,j) * neumann_val
3511 endif
3512
3513 if ((cs%u_face_mask_bdry(i,j) == 2) .OR. &
3514 ((iss%hmask(i+1,j) == 0 .OR. iss%hmask(i+1,j) == 2) .and. (cs%reentrant_x .OR. (i+i_off /= giec)))) then
3515 ! east face of the cell is at a stress boundary
3516 taudx(i,j-1) = taudx(i,j-1) + .5 * g%dyCu(i,j) * neumann_val
3517 taudx(i,j) = taudx(i,j) + .5 * g%dyCu(i,j) * neumann_val
3518 endif
3519
3520 if ((cs%v_face_mask_bdry(i,j-1) == 2) .OR. &
3521 ((iss%hmask(i,j-1) == 0 .OR. iss%hmask(i,j-1) == 2) .and. (cs%reentrant_y .OR. (j+j_off /= gjsc)))) then
3522 ! south face of the cell is at a stress boundary
3523 taudy(i-1,j-1) = taudy(i-1,j-1) - .5 * g%dxCv(i,j-1) * neumann_val
3524 taudy(i,j-1) = taudy(i,j-1) - .5 * g%dxCv(i,j-1) * neumann_val
3525 endif
3526
3527 if ((cs%v_face_mask_bdry(i,j) == 2) .OR. &
3528 ((iss%hmask(i,j+1) == 0 .OR. iss%hmask(i,j+1) == 2) .and. (cs%reentrant_y .OR. (j+j_off /= gjec)))) then
3529 ! north face of the cell is at a stress boundary
3530 taudy(i-1,j) = taudy(i-1,j) + .5 * g%dxCv(i,j) * neumann_val
3531 taudy(i,j) = taudy(i,j) + .5 * g%dxCv(i,j) * neumann_val
3532 endif
3533 else ! This is not an ice-filled cell, so zero out the slopes here
3534 cs%sx_shelf(i,j) = 0.0 ; cs%sy_shelf(i,j) = 0.0
3535 sx_e(i,j) = 0.0
3536 sy_e(i,j) = 0.0
3537 endif
3538 enddo
3539 enddo
3540
3541 do j=jsc-1,jec ; do i=isc-1,iec
3542 taudx(i,j) = taudx(i,j) + ((sx_e(i,j)+sx_e(i+1,j+1)) + (sx_e(i+1,j)+sx_e(i,j+1)))
3543 taudy(i,j) = taudy(i,j) + ((sy_e(i,j)+sy_e(i+1,j+1)) + (sy_e(i+1,j)+sy_e(i,j+1)))
3544 enddo ; enddo
3545end subroutine calc_shelf_driving_stress
3546
3547subroutine cg_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, &
3548 ice_visc, float_cond, bathyT, u_curr, v_curr, G, US, is, ie, js, je, dens_ratio, use_newton_in)
3549
3550 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
3551 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
3552 real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
3553 intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2].
3554 real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
3555 intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2].
3556 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
3557 intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian
3558 !! quadrature points surrounding the cell vertices [L-1 ~> m-1].
3559 real, dimension(:,:,:,:,:,:), &
3560 intent(in) :: Phisub !< Quadrature structure weights at subgridscale
3561 !! locations for finite element calculations [nondim]
3562 real, dimension(SZDIB_(G),SZDJB_(G)), &
3563 intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1]
3564 real, dimension(SZDIB_(G),SZDJB_(G)), &
3565 intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1]
3566 real, dimension(SZDIB_(G),SZDJB_(G)), &
3567 intent(in) :: umask !< A coded mask indicating the nature of the
3568 !! zonal flow at the corner point
3569 real, dimension(SZDIB_(G),SZDJB_(G)), &
3570 intent(in) :: vmask !< A coded mask indicating the nature of the
3571 !! meridional flow at the corner point
3572 real, dimension(SZDIB_(G),SZDJB_(G)), &
3573 intent(in) :: H_node !< The ice shelf thickness at nodal (corner)
3574 !! points [Z ~> m].
3575 real, dimension(SZDI_(G),SZDJ_(G)), &
3576 intent(in) :: hmask !< A mask indicating which tracer points are
3577 !! partly or fully covered by an ice-shelf
3578 real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), &
3579 intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's
3580 !! flow law [R L4 Z T-1 ~> kg m2 s-1].
3581 real, dimension(SZDI_(G),SZDJ_(G)), &
3582 intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing
3583 !! the grounding line (float_cond=1) or not (float_cond=0)
3584 real, dimension(SZDI_(G),SZDJ_(G)), &
3585 intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points
3586 !! relative to sea-level [Z ~> m].
3587 real, dimension(SZDIB_(G),SZDJB_(G)), &
3588 intent(in) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction
3589 !! at quadrature points [L T-1 ~> m s-1]
3590 real, dimension(SZDIB_(G),SZDJB_(G)), &
3591 intent(in) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction
3592 !! at quadrature points [L T-1 ~> m s-1]
3593
3594 real, intent(in) :: dens_ratio !< The density of ice divided by the density
3595 !! of seawater, nondimensional
3596 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
3597 integer, intent(in) :: is !< The starting i-index to work on
3598 integer, intent(in) :: ie !< The ending i-index to work on
3599 integer, intent(in) :: js !< The starting j-index to work on
3600 integer, intent(in) :: je !< The ending j-index to work on
3601 logical, optional, intent(in) :: use_newton_in !< If present, overrides CS%doing_newton for Newton correction
3602
3603! the linear action of the matrix on (u,v) with bilinear finite elements
3604! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced,
3605! but this may change pursuant to conversations with others
3606!
3607! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine
3608! in order to make less frequent halo updates
3609
3610! the linear action of the matrix on (u,v) with bilinear finite elements
3611! Phi has the form
3612! Phi(k,q,i,j) - applies to cell i,j
3613
3614 ! 3 - 4
3615 ! | |
3616 ! 1 - 2
3617
3618! Phi(2*k-1,q,i,j) gives d(Phi_k)/dx at quadrature point q
3619! Phi(2*k,q,i,j) gives d(Phi_k)/dy at quadrature point q
3620! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear
3621
3622 real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1]
3623 real :: uq, vq ! Interpolated direction-vector δu at quadrature point [L T-1 ~> m s-1]
3624 real :: strx_n, stry_n, strsh_n, dstrain_n ! Newton viscosity correction variables [T-1 ~> s-1], [T-2 ~> s-2]
3625 real :: u_curr_qp, v_curr_qp ! Current iterate u^k at quadrature point [L T-1 ~> m s-1]
3626 real :: unorm2_qp ! Regularized squared speed of u^k at quadrature point [L2 T-2 ~> m2 s-2]
3627 real :: basal_coef_qp ! Picard basal friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1]
3628 real :: drag_newt_qp ! Newton basal drag coefficient at quadrature point [R Z T-1 ~> kg m-2 s-1]
3629 real :: inner_dot_qp ! u^k_qp · δu_qp inner product for Newton basal drag [L2 T-2 ~> m2 s-2]
3630 real :: coef_prefactor_e ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1]
3631 real :: eps_vel2_e ! Velocity regularization squared for current element [L2 T-2 ~> m2 s-2]
3632 real :: min_trac_e ! min_basal_traction * areaT for current element [R L2 Z T-1 ~> kg s-1]
3633 real :: fB_e ! Pre-computed Coulomb fB for element; 0 for Weertman [(s m-1)^CF_PostPeak]
3634 real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim]
3635 integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv
3636 logical :: visc_qp4
3637 logical :: use_newton ! Whether to apply Newton tangent stiffness corrections
3638 logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections
3639 real, dimension(2) :: xquad ! Nondimensional quadrature ratios [nondim]
3640 real, dimension(2,2) :: Usub, Vsub ! Subgrid nodal contributions to basal traction [R L3 Z T-2 ~> kg m s-2]
3641 real, dimension(2,2) :: Hcell ! Ice shelf thickness at nodal (corner) points [Z ~> m]
3642 real, dimension(2,2,4) :: uret_qp, vret_qp ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2]
3643 real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2]
3644
3645 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
3646
3647 if (cs%visc_qps == 4) then
3648 visc_qp4=.true.
3649 else
3650 visc_qp4=.false.
3651 qpv = 1
3652 endif
3653
3654 use_newton = cs%doing_newton
3655 if (present(use_newton_in)) use_newton = use_newton_in
3656 do_newton_visc = use_newton .and. trim(cs%ice_viscosity_compute) == "MODEL"
3657
3658 uret(:,:) = 0.0 ; vret(:,:) = 0.0
3659 uret_b(:,:,:) = 0.0 ; vret_b(:,:,:) = 0.0
3660
3661 do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then
3662
3663 uret_qp(:,:,:) = 0.0 ; vret_qp(:,:,:) = 0.0
3664
3665 ! Pre-computed element-level basal friction quantities (updated each outer Newton iteration
3666 ! by calc_shelf_basal_prefactors; avoids O(N_cg) recomputation of expensive prefactors).
3667 coef_prefactor_e = cs%coef_prefactor(i,j)
3668 eps_vel2_e = cs%eps_glen_min**2 * ((g%dxT(i,j)**2) + (g%dyT(i,j)**2))
3669 min_trac_e = cs%min_basal_traction * g%areaT(i,j)
3670 fb_e = cs%fB_elem(i,j) ! 0 for Weertman; non-zero for Coulomb
3671
3672 do iq=1,2 ; do jq=1,2
3673
3674 qp = 2*(jq-1)+iq !current quad point
3675
3676 uq = ((u_shlf(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
3677 (u_shlf(i,j) * (xquad(iq) * xquad(jq)))) + &
3678 ((u_shlf(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
3679 (u_shlf(i-1,j) * (xquad(3-iq) * xquad(jq))))
3680
3681 vq = ((v_shlf(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
3682 (v_shlf(i,j) * (xquad(iq) * xquad(jq)))) + &
3683 ((v_shlf(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
3684 (v_shlf(i-1,j) * (xquad(3-iq) * xquad(jq))))
3685
3686 ux = ((u_shlf(i-1,j-1) * phi(1,qp,i,j)) + &
3687 (u_shlf(i,j) * phi(7,qp,i,j))) + &
3688 ((u_shlf(i,j-1) * phi(3,qp,i,j)) + &
3689 (u_shlf(i-1,j) * phi(5,qp,i,j)))
3690
3691 vx = ((v_shlf(i-1,j-1) * phi(1,qp,i,j)) + &
3692 (v_shlf(i,j) * phi(7,qp,i,j))) + &
3693 ((v_shlf(i,j-1) * phi(3,qp,i,j)) + &
3694 (v_shlf(i-1,j) * phi(5,qp,i,j)))
3695
3696 uy = ((u_shlf(i-1,j-1) * phi(2,qp,i,j)) + &
3697 (u_shlf(i,j) * phi(8,qp,i,j))) + &
3698 ((u_shlf(i,j-1) * phi(4,qp,i,j)) + &
3699 (u_shlf(i-1,j) * phi(6,qp,i,j)))
3700
3701 vy = ((v_shlf(i-1,j-1) * phi(2,qp,i,j)) + &
3702 (v_shlf(i,j) * phi(8,qp,i,j))) + &
3703 ((v_shlf(i,j-1) * phi(4,qp,i,j)) + &
3704 (v_shlf(i-1,j) * phi(6,qp,i,j)))
3705
3706 if (visc_qp4) qpv = qp !current quad point for viscosity
3707
3708 ! Newton correction: compute dstrain scalar once per quadrature point
3709 if (do_newton_visc) then
3710 strx_n = cs%newton_str_ux(i,j,qpv)
3711 stry_n = cs%newton_str_vy(i,j,qpv)
3712 strsh_n = cs%newton_str_sh(i,j,qpv)
3713 dstrain_n = (((2.*strx_n + stry_n)*ux) + ((2.*stry_n + strx_n)*vy)) + &
3714 (strsh_n * (uy + vx) * 0.5)
3715 endif
3716
3717 ! Basal friction and Newton Jacobian evaluated at this quadrature point (fully grounded cells only).
3718 ! Evaluating at quadrature points rather than cell-averaged ensures the Newton correction is the
3719 ! exact Jacobian of the Picard residual, enabling quadratic convergence for all friction exponents.
3720 if (float_cond(i,j) == 0 .and. cs%ground_frac(i,j)>0) then
3721 u_curr_qp = ((u_curr(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
3722 (u_curr(i,j) * (xquad(iq) * xquad(jq)))) + &
3723 ((u_curr(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
3724 (u_curr(i-1,j) * (xquad(3-iq) * xquad(jq))))
3725 v_curr_qp = ((v_curr(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
3726 (v_curr(i,j) * (xquad(iq) * xquad(jq)))) + &
3727 ((v_curr(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
3728 (v_curr(i-1,j) * (xquad(3-iq) * xquad(jq))))
3729 unorm2_qp = ((u_curr_qp**2) + (v_curr_qp**2)) + eps_vel2_e
3730 call compute_basal_coef(unorm2_qp, coef_prefactor_e, min_trac_e, fb_e, &
3731 cs%n_basal_fric, cs%CoulombFriction, cs%CF_PostPeak, us%L_T_to_m_s, use_newton, &
3732 basal_coef_qp, drag_newt_qp)
3733 ! Apply ground fraction scaling (replaces external scaling of basal_traction)
3734 basal_coef_qp = basal_coef_qp * cs%ground_frac(i,j)
3735 if (use_newton) then
3736 drag_newt_qp = drag_newt_qp * cs%ground_frac(i,j)
3737 ! Inner product u^k_qp . delta_u_qp for the Newton correction.
3738 inner_dot_qp = (u_curr_qp * uq) + (v_curr_qp * vq)
3739 endif
3740 endif
3741
3742 ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for
3743 ! non-rectangular elements where opposite cell edges have unequal lengths.
3744 jac_wt = cs%Jac(qp,i,j) * g%IareaT(i,j)
3745
3746 do jphi=1,2 ; jtgt = j-2+jphi ; do iphi=1,2 ; itgt = i-2+iphi
3747 if (umask(itgt,jtgt) == 1) uret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * &
3748 (((4*ux+2*vy) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
3749 ((uy+vx) * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
3750 if (vmask(itgt,jtgt) == 1) vret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * &
3751 (((uy+vx) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
3752 ((4*vy+2*ux) * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
3753
3754 ! Newton viscosity tangent stiffness: (dη/dε_e^2) * (g·δε) * (g·φ_m).
3755 if (do_newton_visc) then
3756 if (umask(itgt,jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + &
3757 jac_wt * cs%newton_visc_factor(i,j,qpv) * dstrain_n * &
3758 (((2.*strx_n + stry_n) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
3759 (strsh_n * 0.5 * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
3760 if (vmask(itgt,jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
3761 jac_wt * cs%newton_visc_factor(i,j,qpv) * dstrain_n * &
3762 ((strsh_n * 0.5 * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
3763 ((2.*stry_n + strx_n) * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
3764 endif
3765
3766 if (float_cond(i,j) == 0 .and. cs%ground_frac(i,j)>0) then
3767 ilq = 1 ; if (iq == iphi) ilq = 2
3768 jlq = 1 ; if (jq == jphi) jlq = 2
3769 ! Picard basal drag: C*|u^k|^(m-1) * δu evaluated at quadrature point, weighted by φ_m
3770 if (umask(itgt,jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + &
3771 (jac_wt * (basal_coef_qp * uq) * (xquad(ilq) * xquad(jlq)))
3772 if (vmask(itgt,jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
3773 (jac_wt * (basal_coef_qp * vq) * (xquad(ilq) * xquad(jlq)))
3774 ! Newton basal drag: pointwise Jacobian of the Picard residual.
3775 ! Tangent stiffness = basal_coef_qp*I + drag_newt_qp * u^k_qp ⊗ u^k_qp
3776 if (use_newton) then
3777 if (umask(itgt,jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + &
3778 jac_wt * drag_newt_qp * u_curr_qp * inner_dot_qp * (xquad(ilq) * xquad(jlq))
3779 if (vmask(itgt,jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
3780 jac_wt * drag_newt_qp * v_curr_qp * inner_dot_qp * (xquad(ilq) * xquad(jlq))
3781 endif
3782 endif
3783 enddo ; enddo
3784 enddo ; enddo
3785
3786 !element contribution to SW node (node 1, which sees the current element as element 4)
3787 uret_b(i-1,j-1,4) = 0.25*((uret_qp(1,1,1)+uret_qp(1,1,4))+(uret_qp(1,1,2)+uret_qp(1,1,3)))
3788 vret_b(i-1,j-1,4) = 0.25*((vret_qp(1,1,1)+vret_qp(1,1,4))+(vret_qp(1,1,2)+vret_qp(1,1,3)))
3789
3790 !element contribution to NW node (node 3, which sees the current element as element 2)
3791 uret_b(i-1,j ,2) = 0.25*((uret_qp(1,2,1)+uret_qp(1,2,4))+(uret_qp(1,2,2)+uret_qp(1,2,3)))
3792 vret_b(i-1,j ,2) = 0.25*((vret_qp(1,2,1)+vret_qp(1,2,4))+(vret_qp(1,2,2)+vret_qp(1,2,3)))
3793
3794 !element contribution to SE node (node 2, which sees the current element as element 3)
3795 uret_b(i ,j-1,3) = 0.25*((uret_qp(2,1,1)+uret_qp(2,1,4))+(uret_qp(2,1,2)+uret_qp(2,1,3)))
3796 vret_b(i ,j-1,3) = 0.25*((vret_qp(2,1,1)+vret_qp(2,1,4))+(vret_qp(2,1,2)+vret_qp(2,1,3)))
3797
3798 !element contribution to NE node (node 4, which sees the current element as element 1)
3799 uret_b(i ,j ,1) = 0.25*((uret_qp(2,2,1)+uret_qp(2,2,4))+(uret_qp(2,2,2)+uret_qp(2,2,3)))
3800 vret_b(i ,j ,1) = 0.25*((vret_qp(2,2,1)+vret_qp(2,2,4))+(vret_qp(2,2,2)+vret_qp(2,2,3)))
3801
3802 if (float_cond(i,j) == 1) then
3803 ! Subgrid grounding-line: evaluate basal friction at each grounded sub-quadrature point.
3804 ! Picard and Newton Jacobian are both computed inside CG_action_subgrid_basal.
3805 hcell(:,:) = h_node(i-1:i,j-1:j)
3806 call cg_action_subgrid_basal(cs, g, us, phisub, hcell, &
3807 u_curr(i-1:i,j-1:j), v_curr(i-1:i,j-1:j), &
3808 u_shlf(i-1:i,j-1:j), v_shlf(i-1:i,j-1:j), &
3809 bathyt(i,j), dens_ratio, i, j, fb_e, use_newton, usub, vsub, &
3810 g%dxCv(i,j-1), g%dxCv(i,j), g%dyCu(i-1,j), g%dyCu(i,j), g%IareaT(i,j))
3811 if (umask(i-1,j-1) == 1) uret_b(i-1,j-1,4) = uret_b(i-1,j-1,4) + usub(1,1)
3812 if (umask(i-1,j ) == 1) uret_b(i-1,j ,2) = uret_b(i-1,j ,2) + usub(1,2)
3813 if (umask(i ,j-1) == 1) uret_b(i ,j-1,3) = uret_b(i ,j-1,3) + usub(2,1)
3814 if (umask(i ,j ) == 1) uret_b(i ,j ,1) = uret_b(i ,j ,1) + usub(2,2)
3815 if (vmask(i-1,j-1) == 1) vret_b(i-1,j-1,4) = vret_b(i-1,j-1,4) + vsub(1,1)
3816 if (vmask(i-1,j ) == 1) vret_b(i-1,j ,2) = vret_b(i-1,j ,2) + vsub(1,2)
3817 if (vmask(i ,j-1) == 1) vret_b(i ,j-1,3) = vret_b(i ,j-1,3) + vsub(2,1)
3818 if (vmask(i ,j ) == 1) vret_b(i ,j ,1) = vret_b(i ,j ,1) + vsub(2,2)
3819 endif
3820 endif ; enddo ; enddo
3821
3822 do j=js-1,je ; do i=is-1,ie
3823 uret(i,j) = (uret_b(i,j,1)+uret_b(i,j,4)) + (uret_b(i,j,2)+uret_b(i,j,3))
3824 vret(i,j) = (vret_b(i,j,1)+vret_b(i,j,4)) + (vret_b(i,j,2)+vret_b(i,j,3))
3825 enddo ; enddo
3826
3827end subroutine cg_action
3828
3829!> Compute subgrid grounding-line basal traction nodal contributions for a CG action.
3830!! Evaluates basal friction (Picard and Newton Jacobian) at each grounded sub-quadrature point.
3831!! The sub-qp flotation test accounts for partial grounding; no external ground_frac scaling needed.
3832subroutine cg_action_subgrid_basal(CS, G, US, Phisub, H, U_curr, V_curr, U_delta, V_delta, &
3833 bathyT, dens_ratio, i_elem, j_elem, fB_e, use_newton, Ucontr, Vcontr, &
3834 dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT)
3835 type(ice_shelf_dyn_cs), intent(in) :: CS !< Ice shelf control structure
3836 type(ocean_grid_type), intent(in) :: G !< The grid structure
3837 type(unit_scale_type), intent(in) :: US !< Unit conversion factors
3838 real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Sub-grid quadrature weights [nondim]
3839 real, dimension(2,2), intent(in) :: H !< Ice thickness at element corners [Z ~> m]
3840 real, dimension(2,2), intent(in) :: U_curr !< Frozen u^k at element corners [L T-1 ~> m s-1]
3841 real, dimension(2,2), intent(in) :: V_curr !< Frozen v^k at element corners [L T-1 ~> m s-1]
3842 real, dimension(2,2), intent(in) :: U_delta !< Search direction δu at element corners [L T-1 ~> m s-1]
3843 real, dimension(2,2), intent(in) :: V_delta !< Search direction δv at element corners [L T-1 ~> m s-1]
3844 real, intent(in) :: bathyT !< Ocean bathymetry depth at tracer point [Z ~> m]
3845 real, intent(in) :: dens_ratio !< Ice density / water density [nondim]
3846 integer, intent(in) :: i_elem !< Tracer-grid i-index of the element
3847 integer, intent(in) :: j_elem !< Tracer-grid j-index of the element
3848 real, intent(in) :: fB_e !< Element Coulomb parameter fB; 0 for Weertman [(s m-1)^CF_PostPeak]
3849 logical, intent(in) :: use_newton !< If true, include Newton basal drag correction
3850 real, dimension(2,2), intent(out) :: Ucontr !< Nodal u-contributions with friction applied [R L3 Z T-2 ~> kg m s-2]
3851 real, dimension(2,2), intent(out) :: Vcontr !< Nodal v-contributions with friction applied [R L3 Z T-2 ~> kg m s-2]
3852 real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m]
3853 real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m]
3854 real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m]
3855 real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m]
3856 real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2]
3857
3858 real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr
3859 !! at each sub-cell
3860 real, dimension(2,2,2,2) :: U_qp_nd, V_qp_nd ! Per-qp nodal contributions (qx,qy,m,n)
3861 ! accumulated then pair-summed for rotation invariance
3862 real :: hloc ! Local sub-cell ice thickness [Z ~> m]
3863 real :: u_curr_loc ! Frozen u^k interpolated to sub-qp [L T-1 ~> m s-1]
3864 real :: v_curr_loc ! Frozen v^k interpolated to sub-qp [L T-1 ~> m s-1]
3865 real :: u_delta_loc ! Search direction δu interpolated to sub-qp [L T-1 ~> m s-1]
3866 real :: v_delta_loc ! Search direction δv interpolated to sub-qp [L T-1 ~> m s-1]
3867 real :: unorm2_loc ! Regularized |u^k|^2 at sub-qp [L2 T-2 ~> m2 s-2]
3868 real :: basal_coef_loc ! Picard friction coefficient at sub-qp [R L2 Z T-1 ~> kg s-1]
3869 real :: drag_newt_loc ! Newton drag coefficient at sub-qp [R Z T ~> kg m-2 s]
3870 real :: inner_dot_loc ! u^k · δu inner product at sub-qp [L2 T-2 ~> m2 s-2]
3871 real :: phi_mn ! Basis function value at sub-qp [nondim]
3872 real :: contrib ! Quadrature weight contribution [nondim]
3873 real :: coef_prefactor ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1]
3874 real :: min_trac_area ! Minimum area-integrated traction floor [R L2 Z T-1 ~> kg s-1]
3875 real :: eps_vel2 ! Velocity regularization squared [L2 T-2 ~> m2 s-2]
3876 real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim]
3877 real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m]
3878 real :: subarea ! Fractional sub-cell area [nondim]
3879 integer :: nsub, i, j, qx, qy, m, n
3880
3881 nsub = size(phisub, 3)
3882 subarea = 1.0 / real(nsub)**2
3883
3884 coef_prefactor = cs%coef_prefactor(i_elem,j_elem)
3885 min_trac_area = cs%min_basal_traction * g%areaT(i_elem,j_elem)
3886 eps_vel2 = cs%eps_glen_min**2 * ((g%dxT(i_elem,j_elem)**2) + (g%dyT(i_elem,j_elem)**2))
3887
3888 ucontr_sub(:,:,:,:) = 0.0 ; vcontr_sub(:,:,:,:) = 0.0
3889
3890 do j=1,nsub ; do i=1,nsub
3891 u_qp_nd(:,:,:,:) = 0.0 ; v_qp_nd(:,:,:,:) = 0.0
3892 do qy=1,2 ; do qx=1,2
3893 hloc = ((phisub(qx,qy,i,j,1,1)*h(1,1)) + (phisub(qx,qy,i,j,2,2)*h(2,2))) + &
3894 ((phisub(qx,qy,i,j,1,2)*h(1,2)) + (phisub(qx,qy,i,j,2,1)*h(2,1)))
3895 if (dens_ratio * hloc - bathyt > 0) then ! grounded sub-qp
3896 u_curr_loc = (((phisub(qx,qy,i,j,1,1)*u_curr(1,1)) + (phisub(qx,qy,i,j,2,2)*u_curr(2,2))) + &
3897 ((phisub(qx,qy,i,j,1,2)*u_curr(1,2)) + (phisub(qx,qy,i,j,2,1)*u_curr(2,1))))
3898 v_curr_loc = (((phisub(qx,qy,i,j,1,1)*v_curr(1,1)) + (phisub(qx,qy,i,j,2,2)*v_curr(2,2))) + &
3899 ((phisub(qx,qy,i,j,1,2)*v_curr(1,2)) + (phisub(qx,qy,i,j,2,1)*v_curr(2,1))))
3900 u_delta_loc = (((phisub(qx,qy,i,j,1,1)*u_delta(1,1)) + (phisub(qx,qy,i,j,2,2)*u_delta(2,2))) + &
3901 ((phisub(qx,qy,i,j,1,2)*u_delta(1,2)) + (phisub(qx,qy,i,j,2,1)*u_delta(2,1))))
3902 v_delta_loc = (((phisub(qx,qy,i,j,1,1)*v_delta(1,1)) + (phisub(qx,qy,i,j,2,2)*v_delta(2,2))) + &
3903 ((phisub(qx,qy,i,j,1,2)*v_delta(1,2)) + (phisub(qx,qy,i,j,2,1)*v_delta(2,1))))
3904
3905 unorm2_loc = ((u_curr_loc**2) + (v_curr_loc**2)) + eps_vel2
3906 call compute_basal_coef(unorm2_loc, coef_prefactor, min_trac_area, fb_e, &
3907 cs%n_basal_fric, cs%CoulombFriction, cs%CF_PostPeak, us%L_T_to_m_s, use_newton, &
3908 basal_coef_loc, drag_newt_loc)
3909 inner_dot_loc = (u_curr_loc * u_delta_loc) + (v_curr_loc * v_delta_loc)
3910
3911 ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values
3912 ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation
3913 ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x.
3914 ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines.
3915 a = (dxcv_s * (phisub(qx,qy,i,j,1,1) + phisub(qx,qy,i,j,2,1))) + & ! (1-y) * dxCv_S
3916 (dxcv_n * (phisub(qx,qy,i,j,1,2) + phisub(qx,qy,i,j,2,2))) ! + y * dxCv_N
3917 d = (dycu_w * (phisub(qx,qy,i,j,1,1) + phisub(qx,qy,i,j,1,2))) + & ! (1-x) * dyCu_W
3918 (dycu_e * (phisub(qx,qy,i,j,2,1) + phisub(qx,qy,i,j,2,2))) ! + x * dyCu_E
3919 jac_sub_wt = 0.25 * subarea * (a * d) * iareat
3920
3921 do n=1,2 ; do m=1,2
3922 phi_mn = phisub(qx,qy,i,j,m,n)
3923 contrib = jac_sub_wt * phi_mn
3924 ! Picard: friction matrix applied to search direction δu
3925 u_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc * u_delta_loc)
3926 v_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc * v_delta_loc)
3927 ! Newton: Jacobian d(tau_b_i)/d(u_j) = basal_coef*I + drag_newt*u^k_i*u^k_j
3928 if (use_newton) then
3929 u_qp_nd(qx,qy,m,n) = u_qp_nd(qx,qy,m,n) + (contrib * (drag_newt_loc * u_curr_loc * inner_dot_loc))
3930 v_qp_nd(qx,qy,m,n) = v_qp_nd(qx,qy,m,n) + (contrib * (drag_newt_loc * v_curr_loc * inner_dot_loc))
3931 endif
3932 enddo ; enddo
3933 endif
3934 enddo ; enddo
3935
3936 do n=1,2 ; do m=1,2
3937 ucontr_sub(i,j,m,n) = (u_qp_nd(1,1,m,n) + u_qp_nd(2,2,m,n)) + &
3938 (u_qp_nd(1,2,m,n) + u_qp_nd(2,1,m,n))
3939 vcontr_sub(i,j,m,n) = (v_qp_nd(1,1,m,n) + v_qp_nd(2,2,m,n)) + &
3940 (v_qp_nd(1,2,m,n) + v_qp_nd(2,1,m,n))
3941 enddo ; enddo
3942 enddo ; enddo
3943
3944 do n=1,2 ; do m=1,2
3945 call sum_square_matrix(ucontr(m,n), ucontr_sub(:,:,m,n), nsub)
3946 call sum_square_matrix(vcontr(m,n), vcontr_sub(:,:,m,n), nsub)
3947 enddo ; enddo
3948
3949end subroutine cg_action_subgrid_basal
3950
3951!> Compute the Picard basal friction coefficient and Newton drag coefficient at a
3952!! single quadrature point. Encapsulates the 3-path dispatch (linear Weertman / nonlinear
3953!! Weertman / Coulomb) so that CG_action, matrix_diagonal, and their subgrid equivalents
3954!! remain readable. The ground_frac scaling is NOT applied here; callers do it after the call.
3955subroutine compute_basal_coef(unorm2_qp, coef_prefactor, min_trac_area, fB_e, &
3956 n_basal_fric, CoulombFriction, CF_PostPeak, L_T_to_m_s, use_newton, &
3957 basal_coef, drag_newt)
3958 real, intent(in) :: unorm2_qp !< Regularized |u^k|^2 > 0 at quadrature point [L2 T-2 ~> m2 s-2]
3959 real, intent(in) :: coef_prefactor !< Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1]
3960 real, intent(in) :: min_trac_area !< Pre-computed min_basal_traction * areaT floor [R L2 Z T-1 ~> kg s-1]
3961 real, intent(in) :: fB_e !< Element-level Coulomb fB; 0 for Weertman [(s m-1)^CF_PostPeak]
3962 real, intent(in) :: n_basal_fric !< Friction sliding exponent m [nondim]
3963 logical, intent(in) :: CoulombFriction !< True if using Coulomb friction
3964 real, intent(in) :: CF_PostPeak !< Coulomb post-peak exponent q [nondim]
3965 real, intent(in) :: L_T_to_m_s !< Unit conversion factor from internal [L T-1] to [m s-1]
3966 logical, intent(in) :: use_newton !< If true, evaluate drag_newt; otherwise set to 0
3967 real, intent(out) :: basal_coef !< Picard friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1]
3968 real, intent(out) :: drag_newt !< Newton drag coefficient [R Z T ~> kg m-2 s]; 0 without Newton
3969
3970 real :: unorm ! |u^k| at quadrature point in physical units [m s-1]
3971 real :: raw_coef ! Pre-floor friction coefficient [R L2 Z T-1 ~> kg s-1]
3972 real :: fBuq ! fB_e * |u^k|^q [nondim]
3973
3974 if (n_basal_fric == 1.0 .and. .not. coulombfriction) then
3975 ! Linear Weertman: coef is independent of |u|; sqrt and Newton correction not needed
3976 basal_coef = max(coef_prefactor, min_trac_area)
3977 drag_newt = 0.0
3978 elseif (coulombfriction) then
3979 ! Schoof/Gagliardini Coulomb friction
3980 unorm = l_t_to_m_s * sqrt(unorm2_qp)
3981 fbuq = fb_e * unorm**cf_postpeak
3982 raw_coef = coef_prefactor * (unorm**(n_basal_fric-1.0)) / (1.0 + fbuq)**n_basal_fric
3983 if (raw_coef < min_trac_area) then
3984 basal_coef = min_trac_area ; drag_newt = 0.0
3985 else
3986 basal_coef = raw_coef
3987 if (use_newton) then
3988 drag_newt = (1.0/unorm2_qp) * raw_coef * &
3989 ((n_basal_fric-1.0) - n_basal_fric * cf_postpeak * fbuq / (1.0 + fbuq))
3990 else
3991 drag_newt = 0.0
3992 endif
3993 endif
3994 else
3995 ! Nonlinear Weertman (m > 1)
3996 unorm = l_t_to_m_s * sqrt(unorm2_qp)
3997 raw_coef = coef_prefactor * (unorm**(n_basal_fric-1.0))
3998 if (raw_coef < min_trac_area) then
3999 basal_coef = min_trac_area ; drag_newt = 0.0
4000 else
4001 basal_coef = raw_coef
4002 if (use_newton) then
4003 drag_newt = (n_basal_fric-1.0) / unorm2_qp * raw_coef
4004 else
4005 drag_newt = 0.0
4006 endif
4007 endif
4008 endif
4009
4010end subroutine compute_basal_coef
4011
4012!! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated.
4013subroutine sum_square_matrix(sum_out, mat_in, n)
4014 integer, intent(in) :: n !< The length and width of each matrix in mat_in
4015 real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed
4016 real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in
4017 integer :: s0, e0, s1, e1
4018
4019 sum_out = 0.0
4020
4021 s0 = 1 ; e0 = n
4022
4023 !start by summing elements on outer edges of matrix
4024 do while (s0<e0)
4025
4026 !corners
4027 sum_out = sum_out + ( (mat_in(s0,s0) + mat_in(e0,e0)) + (mat_in(e0,s0) + mat_in(s0,e0)) )
4028
4029 s1 = s0+1 ; e1 = e0-1
4030
4031 do while (s1<e1) !non-corners
4032
4033 sum_out = sum_out + &
4034 ( ( (mat_in(s0,s1) + mat_in(s1,s0)) + (mat_in(e0,e1) + mat_in(e1,e0)) ) + &
4035 ( (mat_in(e1,s0) + mat_in(e0,s1)) + (mat_in(s1,e0) + mat_in(s0,e1)) ) )
4036
4037 s1 = s1+1 ; e1 = e1-1
4038 enddo
4039
4040 !center element of an edge
4041 if (s1==e1) sum_out = sum_out + ( (mat_in(s1,s0) + mat_in(e1,e0)) + (mat_in(e0,e1) + mat_in(s0,s1)) )
4042
4043 s0 = s0+1 ; e0 = e0-1 !next loop iteration using new edges that are one element inward of the current edges
4044 enddo
4045
4046 !center element of entire matrix
4047 if (s0==e0) sum_out = sum_out + mat_in(s0,e0)
4048
4049end subroutine sum_square_matrix
4050
4051!> returns the diagonal entries of the matrix for a Jacobi preconditioning
4052subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, u_curr, v_curr, &
4053 hmask, dens_ratio, Phi, Phisub, u_diagonal, v_diagonal)
4054
4055 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
4056 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4057 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
4058 real, dimension(SZDI_(G),SZDJ_(G)), &
4059 intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing
4060 !! the grounding line (float_cond=1) or not (float_cond=0)
4061 real, dimension(SZDIB_(G),SZDJB_(G)), &
4062 intent(in) :: H_node !< The ice shelf thickness at nodal
4063 !! (corner) points [Z ~> m].
4064 real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), &
4065 intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's
4066 !! flow law [R L4 Z T-1 ~> kg m2 s-1].
4067 real, dimension(SZDIB_(G),SZDJB_(G)), &
4068 intent(in) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction
4069 !! at quadrature points [L T-1 ~> m s-1]
4070 real, dimension(SZDIB_(G),SZDJB_(G)), &
4071 intent(in) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction
4072 !! at quadrature points [L T-1 ~> m s-1]
4073 real, dimension(SZDI_(G),SZDJ_(G)), &
4074 intent(in) :: hmask !< A mask indicating which tracer points are
4075 !! partly or fully covered by an ice-shelf
4076 real, intent(in) :: dens_ratio !< The density of ice divided by the density
4077 !! of seawater [nondim]
4078 real, dimension(8,4,SZDI_(G),SZDJ_(G)), &
4079 intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian
4080 !! quadrature points surrounding the cell vertices [L-1 ~> m-1]
4081 real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale
4082 !! locations for finite element calculations [nondim]
4083 real, dimension(SZDIB_(G),SZDJB_(G)), &
4084 intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity
4085 !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1]
4086 real, dimension(SZDIB_(G),SZDJB_(G)), &
4087 intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity
4088 !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1]
4089
4090
4091! returns the diagonal entries of the matrix for a Jacobi preconditioning
4092
4093 real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1]
4094 real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim]
4095 real :: strx_n, stry_n, strsh_n ! Newton viscosity strain rates [T-1 ~> s-1]
4096 real :: dstrain_diag_u, dstrain_diag_v ! Newton viscosity diagonal correction factors [T-1 L-1 ~> s-1 m-1]
4097 real :: phi_m_sq ! Squared basis function value at quadrature point [nondim]
4098 real :: u_curr_qp, v_curr_qp ! Current iterate u^k at quadrature point [L T-1 ~> m s-1]
4099 real :: unorm2_qp ! Regularized squared speed of u^k at quadrature point [L2 T-2 ~> m2 s-2]
4100 real :: basal_coef_qp ! Picard basal friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1]
4101 real :: drag_newt_qp ! Newton basal drag coefficient at quadrature point [R Z T-1 ~> kg m-2 s-1]
4102 real :: coef_prefactor_e ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1]
4103 real :: eps_vel2_e ! Velocity regularization squared for current element [L2 T-2 ~> m2 s-2]
4104 real :: min_trac_e ! min_basal_traction * areaT for current element [R L2 Z T-1 ~> kg s-1]
4105 real :: fB_e ! Pre-computed Coulomb fB for element; 0 for Weertman [(s m-1)^CF_PostPeak]
4106 real, dimension(2) :: xquad
4107 real, dimension(2,2) :: Hcell, u_diag_sub, v_diag_sub ! Subgrid diagonal contributions [R L2 Z T-1 ~> kg s-1]
4108 real, dimension(2,2,4) :: u_diag_qp, v_diag_qp
4109 real, dimension(SZDIB_(G),SZDJB_(G),4) :: u_diag_b, v_diag_b
4110 logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections
4111 logical :: visc_qp4
4112 integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt, qp, qpv
4113
4114 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
4115
4116 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
4117
4118 if (cs%visc_qps == 4) then
4119 visc_qp4=.true.
4120 else
4121 visc_qp4=.false.
4122 qpv = 1
4123 endif
4124
4125 do_newton_visc = cs%doing_newton .and. trim(cs%ice_viscosity_compute) == "MODEL"
4126
4127 u_diag_b(:,:,:)=0.0
4128 v_diag_b(:,:,:)=0.0
4129
4130 do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then
4131
4132 ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j
4133 ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j
4134
4135 u_diag_qp(:,:,:) = 0.0 ; v_diag_qp(:,:,:) = 0.0
4136
4137 ! Pre-computed element-level basal friction quantities (updated each outer iteration).
4138 coef_prefactor_e = cs%coef_prefactor(i,j)
4139 eps_vel2_e = cs%eps_glen_min**2 * ((g%dxT(i,j)**2) + (g%dyT(i,j)**2))
4140 min_trac_e = cs%min_basal_traction * g%areaT(i,j)
4141 fb_e = cs%fB_elem(i,j) ! 0 for Weertman; non-zero for Coulomb
4142
4143 do iq=1,2 ; do jq=1,2
4144
4145 qp = 2*(jq-1)+iq !current quad point
4146 if (visc_qp4) qpv = qp !current quad point for viscosity
4147
4148 ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for
4149 ! non-rectangular elements where opposite cell edges have unequal lengths.
4150 jac_wt = cs%Jac(qp,i,j) * g%IareaT(i,j)
4151
4152 ! Pre-compute Newton strain data for this QP (for viscosity diagonal correction)
4153 if (do_newton_visc) then
4154 strx_n = cs%newton_str_ux(i,j,qpv)
4155 stry_n = cs%newton_str_vy(i,j,qpv)
4156 strsh_n = cs%newton_str_sh(i,j,qpv)
4157 endif
4158
4159 ! Basal friction coefficients at this quadrature point (fully grounded cells only)
4160 if (float_cond(i,j) == 0 .and. cs%ground_frac(i,j)>0) then
4161 u_curr_qp = ((u_curr(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
4162 (u_curr(i,j) * (xquad(iq) * xquad(jq)))) + &
4163 ((u_curr(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
4164 (u_curr(i-1,j) * (xquad(3-iq) * xquad(jq))))
4165 v_curr_qp = ((v_curr(i-1,j-1) * (xquad(3-iq) * xquad(3-jq))) + &
4166 (v_curr(i,j) * (xquad(iq) * xquad(jq)))) + &
4167 ((v_curr(i,j-1) * (xquad(iq) * xquad(3-jq))) + &
4168 (v_curr(i-1,j) * (xquad(3-iq) * xquad(jq))))
4169 unorm2_qp = ((u_curr_qp**2) + (v_curr_qp**2)) + eps_vel2_e
4170 call compute_basal_coef(unorm2_qp, coef_prefactor_e, min_trac_e, fb_e, &
4171 cs%n_basal_fric, cs%CoulombFriction, cs%CF_PostPeak, us%L_T_to_m_s, .true., &
4172 basal_coef_qp, drag_newt_qp)
4173 basal_coef_qp = basal_coef_qp * cs%ground_frac(i,j)
4174 drag_newt_qp = drag_newt_qp * cs%ground_frac(i,j)
4175 endif
4176
4177 do jphi=1,2 ; jtgt = j-2+jphi ; do iphi=1,2 ; itgt = i-2+iphi
4178
4179 ilq = 1 ; if (iq == iphi) ilq = 2
4180 jlq = 1 ; if (jq == jphi) jlq = 2
4181 phi_m_sq = (xquad(ilq) * xquad(jlq))**2
4182
4183 if (cs%umask(itgt,jtgt) == 1) then
4184
4185 ux = phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)
4186 uy = phi(2*(2*(jphi-1)+iphi),qp,i,j)
4187 vx = 0.
4188 vy = 0.
4189
4190 u_diag_qp(iphi,jphi,qp) = jac_wt * &
4191 ice_visc(i,j,qpv) * (((4*ux+2*vy) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
4192 ((uy+vx) * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
4193
4194 ! Newton viscosity diagonal correction: newton_visc_factor * (g . grad_phi_m_u)^2
4195 ! where grad_phi_m_u = [(2*strx+stry)*Phi_xm + strsh/2*Phi_ym] for u-DOF at node m
4196 if (do_newton_visc) then
4197 dstrain_diag_u = ((2.*strx_n + stry_n) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
4198 (strsh_n * 0.5 * phi(2*(2*(jphi-1)+iphi),qp,i,j))
4199 u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + &
4200 jac_wt * cs%newton_visc_factor(i,j,qpv) * dstrain_diag_u**2
4201 endif
4202
4203 if (float_cond(i,j) == 0 .and. cs%ground_frac(i,j)>0) then
4204 ! Picard diagonal: basal_coef_qp * phi_m^2; Newton diagonal adds drag_newt_qp * u^k_qp^2 * phi_m^2.
4205 u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + jac_wt * basal_coef_qp * phi_m_sq
4206 if (cs%doing_newton) &
4207 u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + jac_wt * drag_newt_qp * u_curr_qp**2 * phi_m_sq
4208 endif
4209 endif
4210
4211 if (cs%vmask(itgt,jtgt) == 1) then
4212
4213 vx = phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)
4214 vy = phi(2*(2*(jphi-1)+iphi),qp,i,j)
4215 ux = 0.
4216 uy = 0.
4217
4218 v_diag_qp(iphi,jphi,qp) = jac_wt * &
4219 ice_visc(i,j,qpv) * (((uy+vx) * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
4220 ((4*vy+2*ux) * phi(2*(2*(jphi-1)+iphi),qp,i,j)))
4221
4222 ! Newton viscosity diagonal correction for v-DOF: uses [strsh/2*Phi_xm + (2*stry+strx)*Phi_ym]
4223 if (do_newton_visc) then
4224 dstrain_diag_v = (strsh_n * 0.5 * phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
4225 ((2.*stry_n + strx_n) * phi(2*(2*(jphi-1)+iphi),qp,i,j))
4226 v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + &
4227 jac_wt * cs%newton_visc_factor(i,j,qpv) * dstrain_diag_v**2
4228 endif
4229
4230 if (float_cond(i,j) == 0 .and. cs%ground_frac(i,j)>0) then
4231 v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + jac_wt * basal_coef_qp * phi_m_sq
4232 if (cs%doing_newton) &
4233 v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + jac_wt * drag_newt_qp * v_curr_qp**2 * phi_m_sq
4234 endif
4235 endif
4236 enddo ; enddo
4237 enddo ; enddo
4238
4239 !element contribution to SW node (node 1, which sees the current element as element 4)
4240 u_diag_b(i-1,j-1,4) = 0.25*((u_diag_qp(1,1,1)+u_diag_qp(1,1,4))+(u_diag_qp(1,1,2)+u_diag_qp(1,1,3)))
4241 v_diag_b(i-1,j-1,4) = 0.25*((v_diag_qp(1,1,1)+v_diag_qp(1,1,4))+(v_diag_qp(1,1,2)+v_diag_qp(1,1,3)))
4242
4243 !element contribution to NW node (node 3, which sees the current element as element 2)
4244 u_diag_b(i-1,j ,2) = 0.25*((u_diag_qp(1,2,1)+u_diag_qp(1,2,4))+(u_diag_qp(1,2,2)+u_diag_qp(1,2,3)))
4245 v_diag_b(i-1,j ,2) = 0.25*((v_diag_qp(1,2,1)+v_diag_qp(1,2,4))+(v_diag_qp(1,2,2)+v_diag_qp(1,2,3)))
4246
4247 !element contribution to SE node (node 2, which sees the current element as element 3)
4248 u_diag_b(i ,j-1,3) = 0.25*((u_diag_qp(2,1,1)+u_diag_qp(2,1,4))+(u_diag_qp(2,1,2)+u_diag_qp(2,1,3)))
4249 v_diag_b(i ,j-1,3) = 0.25*((v_diag_qp(2,1,1)+v_diag_qp(2,1,4))+(v_diag_qp(2,1,2)+v_diag_qp(2,1,3)))
4250
4251 !element contribution to NE node (node 4, which sees the current element as element 1)
4252 u_diag_b(i ,j ,1) = 0.25*((u_diag_qp(2,2,1)+u_diag_qp(2,2,4))+(u_diag_qp(2,2,2)+u_diag_qp(2,2,3)))
4253 v_diag_b(i ,j ,1) = 0.25*((v_diag_qp(2,2,1)+v_diag_qp(2,2,4))+(v_diag_qp(2,2,2)+v_diag_qp(2,2,3)))
4254
4255 if (float_cond(i,j) == 1) then
4256 ! Subgrid grounding-line: evaluate basal friction diagonal at each grounded sub-quadrature point.
4257 ! Returns separate u_diag_sub and v_diag_sub (differ in Newton term: u^2 vs v^2).
4258 ! The sub-qp flotation test handles grounding fraction; no external ground_frac scaling needed.
4259 hcell(:,:) = h_node(i-1:i,j-1:j)
4260 call cg_diagonal_subgrid_basal(cs, g, us, phisub, hcell, &
4261 u_curr(i-1:i,j-1:j), v_curr(i-1:i,j-1:j), &
4262 cs%bed_elev(i,j), dens_ratio, i, j, fb_e, u_diag_sub, v_diag_sub, &
4263 g%dxCv(i,j-1), g%dxCv(i,j), g%dyCu(i-1,j), g%dyCu(i,j), g%IareaT(i,j))
4264
4265 if (cs%umask(i-1,j-1)==1) u_diag_b(i-1,j-1,4) = u_diag_b(i-1,j-1,4) + u_diag_sub(1,1)
4266 if (cs%umask(i-1,j )==1) u_diag_b(i-1,j ,2) = u_diag_b(i-1,j ,2) + u_diag_sub(1,2)
4267 if (cs%umask(i ,j-1)==1) u_diag_b(i ,j-1,3) = u_diag_b(i ,j-1,3) + u_diag_sub(2,1)
4268 if (cs%umask(i ,j )==1) u_diag_b(i ,j ,1) = u_diag_b(i ,j ,1) + u_diag_sub(2,2)
4269 if (cs%vmask(i-1,j-1)==1) v_diag_b(i-1,j-1,4) = v_diag_b(i-1,j-1,4) + v_diag_sub(1,1)
4270 if (cs%vmask(i-1,j )==1) v_diag_b(i-1,j ,2) = v_diag_b(i-1,j ,2) + v_diag_sub(1,2)
4271 if (cs%vmask(i ,j-1)==1) v_diag_b(i ,j-1,3) = v_diag_b(i ,j-1,3) + v_diag_sub(2,1)
4272 if (cs%vmask(i ,j )==1) v_diag_b(i ,j ,1) = v_diag_b(i ,j ,1) + v_diag_sub(2,2)
4273 endif
4274 endif ; enddo ; enddo
4275
4276 do j=jsc-2,jec+1 ; do i=isc-2,iec+1
4277 u_diagonal(i,j) = (u_diag_b(i,j,1)+u_diag_b(i,j,4)) + (u_diag_b(i,j,2)+u_diag_b(i,j,3))
4278 v_diagonal(i,j) = (v_diag_b(i,j,1)+v_diag_b(i,j,4)) + (v_diag_b(i,j,2)+v_diag_b(i,j,3))
4279 enddo ; enddo
4280
4281end subroutine matrix_diagonal
4282
4283!> Compute subgrid grounding-line basal traction contributions for the preconditioner diagonal.
4284!! Evaluates friction at each grounded sub-quadrature point. Returns separate u and v diagonals
4285!! because the Newton term uses u^2 for the u-block and v^2 for the v-block.
4286!! The sub-qp flotation test handles partial grounding; no external ground_frac scaling needed.
4287subroutine cg_diagonal_subgrid_basal(CS, G, US, Phisub, H_node, U_curr, V_curr, &
4288 bathyT, dens_ratio, i_elem, j_elem, fB_e, u_diag, v_diag, &
4289 dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT)
4290 type(ice_shelf_dyn_cs), intent(in) :: CS !< Ice shelf control structure
4291 type(ocean_grid_type), intent(in) :: G !< The grid structure
4292 type(unit_scale_type), intent(in) :: US !< Unit conversion factors
4293 real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Sub-grid quadrature weights [nondim]
4294 real, dimension(2,2), intent(in) :: H_node !< Ice thickness at element corners [Z ~> m]
4295 real, dimension(2,2), intent(in) :: U_curr !< Frozen u^k at element corners [L T-1 ~> m s-1]
4296 real, dimension(2,2), intent(in) :: V_curr !< Frozen v^k at element corners [L T-1 ~> m s-1]
4297 real, intent(in) :: bathyT !< Ocean bathymetry depth at tracer point [Z ~> m]
4298 real, intent(in) :: dens_ratio !< Ice density / water density [nondim]
4299 integer, intent(in) :: i_elem !< Tracer-grid i-index of the element
4300 integer, intent(in) :: j_elem !< Tracer-grid j-index of the element
4301 real, intent(in) :: fB_e !< Element Coulomb parameter fB; 0 for Weertman [(s m-1)^CF_PostPeak]
4302 real, dimension(2,2), intent(out) :: u_diag !< Nodal u-diagonal entries [R L2 Z T-1 ~> kg s-1]
4303 real, dimension(2,2), intent(out) :: v_diag !< Nodal v-diagonal entries [R L2 Z T-1 ~> kg s-1]
4304 real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m]
4305 real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m]
4306 real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m]
4307 real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m]
4308 real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2]
4309
4310 real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: u_diag_sub, v_diag_sub
4311 real, dimension(2,2,2,2) :: u_diag_qp_nd, v_diag_qp_nd ! Per-qp nodal diagonal entries (qx,qy,m,n),
4312 ! pair-summed for rotation invariance
4313 real :: hloc ! Local sub-cell ice thickness [Z ~> m]
4314 real :: u_curr_loc ! Frozen u^k interpolated to sub-qp [L T-1 ~> m s-1]
4315 real :: v_curr_loc ! Frozen v^k interpolated to sub-qp [L T-1 ~> m s-1]
4316 real :: unorm2_loc ! Regularized |u^k|^2 at sub-qp [L2 T-2 ~> m2 s-2]
4317 real :: basal_coef_loc ! Picard friction coefficient at sub-qp [R L2 Z T-1 ~> kg s-1]
4318 real :: drag_newt_loc ! Newton drag coefficient at sub-qp [R Z T ~> kg m-2 s]
4319 real :: phi_mn_sq ! Squared basis function value at sub-qp [nondim]
4320 real :: contrib ! Quadrature weight contribution [nondim]
4321 real :: coef_prefactor ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1]
4322 real :: min_trac_area ! Minimum area-integrated traction floor [R L2 Z T-1 ~> kg s-1]
4323 real :: eps_vel2 ! Velocity regularization squared [L2 T-2 ~> m2 s-2]
4324 real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim]
4325 real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m]
4326 real :: subarea ! Fractional sub-cell area [nondim]
4327 integer :: nsub, i, j, qx, qy, m, n
4328
4329 nsub = size(phisub, 3)
4330 subarea = 1.0 / real(nsub)**2
4331
4332 coef_prefactor = cs%coef_prefactor(i_elem,j_elem)
4333 min_trac_area = cs%min_basal_traction * g%areaT(i_elem,j_elem)
4334 eps_vel2 = cs%eps_glen_min**2 * ((g%dxT(i_elem,j_elem)**2) + (g%dyT(i_elem,j_elem)**2))
4335
4336 u_diag_sub(:,:,:,:) = 0.0 ; v_diag_sub(:,:,:,:) = 0.0
4337
4338 do j=1,nsub ; do i=1,nsub
4339 ! Zero the 4-qp per-node buffer so ungrounded qp contribute exactly 0.
4340 u_diag_qp_nd(:,:,:,:) = 0.0 ; v_diag_qp_nd(:,:,:,:) = 0.0
4341 do qy=1,2 ; do qx=1,2
4342 hloc = ((phisub(qx,qy,i,j,1,1)*h_node(1,1)) + (phisub(qx,qy,i,j,2,2)*h_node(2,2))) + &
4343 ((phisub(qx,qy,i,j,1,2)*h_node(1,2)) + (phisub(qx,qy,i,j,2,1)*h_node(2,1)))
4344 if (dens_ratio * hloc - bathyt > 0) then ! grounded sub-qp
4345 u_curr_loc = (((phisub(qx,qy,i,j,1,1)*u_curr(1,1)) + (phisub(qx,qy,i,j,2,2)*u_curr(2,2))) + &
4346 ((phisub(qx,qy,i,j,1,2)*u_curr(1,2)) + (phisub(qx,qy,i,j,2,1)*u_curr(2,1))))
4347 v_curr_loc = (((phisub(qx,qy,i,j,1,1)*v_curr(1,1)) + (phisub(qx,qy,i,j,2,2)*v_curr(2,2))) + &
4348 ((phisub(qx,qy,i,j,1,2)*v_curr(1,2)) + (phisub(qx,qy,i,j,2,1)*v_curr(2,1))))
4349
4350 unorm2_loc = ((u_curr_loc**2) + (v_curr_loc**2)) + eps_vel2
4351 call compute_basal_coef(unorm2_loc, coef_prefactor, min_trac_area, fb_e, &
4352 cs%n_basal_fric, cs%CoulombFriction, cs%CF_PostPeak, us%L_T_to_m_s, .true., &
4353 basal_coef_loc, drag_newt_loc)
4354 ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values
4355 ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation
4356 ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x.
4357 ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines.
4358 a = (dxcv_s * (phisub(qx,qy,i,j,1,1) + phisub(qx,qy,i,j,2,1))) + & ! (1-y) * dxCv_S
4359 (dxcv_n * (phisub(qx,qy,i,j,1,2) + phisub(qx,qy,i,j,2,2))) ! + y * dxCv_N
4360 d = (dycu_w * (phisub(qx,qy,i,j,1,1) + phisub(qx,qy,i,j,1,2))) + & ! (1-x) * dyCu_W
4361 (dycu_e * (phisub(qx,qy,i,j,2,1) + phisub(qx,qy,i,j,2,2))) ! + x * dyCu_E
4362 jac_sub_wt = 0.25 * subarea * (a * d) * iareat
4363
4364 do n=1,2 ; do m=1,2
4365 phi_mn_sq = phisub(qx,qy,i,j,m,n)**2
4366 contrib = jac_sub_wt * phi_mn_sq
4367 ! Picard diagonal + Newton diagonal (u_curr^2 for u-block, v_curr^2 for v-block)
4368 if (cs%doing_newton) then
4369 u_diag_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc + drag_newt_loc * u_curr_loc**2)
4370 v_diag_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc + drag_newt_loc * v_curr_loc**2)
4371 else
4372 u_diag_qp_nd(qx,qy,m,n) = contrib * basal_coef_loc
4373 v_diag_qp_nd(qx,qy,m,n) = contrib * basal_coef_loc
4374 endif
4375 enddo ; enddo
4376 endif
4377 enddo ; enddo
4378
4379 do n=1,2 ; do m=1,2
4380 u_diag_sub(i,j,m,n) = (u_diag_qp_nd(1,1,m,n) + u_diag_qp_nd(2,2,m,n)) + &
4381 (u_diag_qp_nd(1,2,m,n) + u_diag_qp_nd(2,1,m,n))
4382 v_diag_sub(i,j,m,n) = (v_diag_qp_nd(1,1,m,n) + v_diag_qp_nd(2,2,m,n)) + &
4383 (v_diag_qp_nd(1,2,m,n) + v_diag_qp_nd(2,1,m,n))
4384 enddo ; enddo
4385 enddo ; enddo
4386
4387 do n=1,2 ; do m=1,2
4388 call sum_square_matrix(u_diag(m,n), u_diag_sub(:,:,m,n), nsub)
4389 call sum_square_matrix(v_diag(m,n), v_diag_sub(:,:,m,n), nsub)
4390 enddo ; enddo
4391
4392end subroutine cg_diagonal_subgrid_basal
4393
4394!> Post_data calls related to ice-sheet flux divergence, strain-rate, and deviatoric stress
4395subroutine is_dynamics_post_data_2(CS, ISS, G)
4396 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
4397 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
4398 !! the ice-shelf state
4399 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4400 real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m].
4401 real, dimension(SZDIB_(G),SZDJB_(G)) :: Hu ! Ice shelf u_flux at corners [Z L T-1 ~> m2 s-1].
4402 real, dimension(SZDIB_(G),SZDJB_(G)) :: Hv ! Ice shelf v_flux at corners [Z L T-1 ~> m2 s-1].
4403 real, dimension(SZDI_(G),SZDJ_(G)) :: Hux ! Ice shelf d(u_flux)/dx at cell centers [Z T-1 ~> m s-1].
4404 real, dimension(SZDI_(G),SZDJ_(G)) :: Hvy ! Ice shelf d(v_flux)/dy at cell centers [Z T-1 ~> m s-1].
4405 real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! horizontal flux divergence div(uH) [Z T-1 ~> m s-1].
4406 real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! strain-rate components xx,yy, and xy [T-1 ~> s-1]
4407 real, dimension(SZDI_(G),SZDJ_(G),2) :: p_strain_rate ! horizontal principal strain-rates [T-1 ~> s-1]
4408 real, dimension(SZDI_(G),SZDJ_(G),3) :: dev_stress ! deviatoric stress components xx,yy, and xy [R L Z T-2 ~> Pa]
4409 real, dimension(SZDI_(G),SZDJ_(G),2) :: p_dev_stress ! horizontal principal deviatoric stress [R L Z T-2 ~> Pa]
4410 real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s]
4411 real :: p1, p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1]
4412 integer :: i, j
4413
4414 !Allocate the gradient basis functions for 1 cell-centered quadrature point per cell
4415 if (.not. associated(cs%PhiC)) then
4416 allocate(cs%PhiC(1:8,g%isc:g%iec,g%jsc:g%jec), source=0.0)
4417 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4418 call bilinear_shape_fn_grid_1qp(g, i, j, cs%PhiC(:,i,j))
4419 enddo ; enddo
4420 endif
4421
4422 !Calculate flux divergence and its components
4423 if (cs%id_duHdx > 0 .or. cs%id_dvHdy > 0 .or. cs%id_fluxdiv > 0) then
4424 call interpolate_h_to_b(g, iss%h_shelf, iss%hmask, h_node, cs%min_h_shelf)
4425
4426 hu(:,:) = 0.0 ; hv(:,:) = 0.0 ; hux(:,:) = 0.0 ; hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0
4427 do j=g%jscB,g%jecB ; do i=g%iscB,g%iecB
4428 if (cs%umask(i,j) > 0) then
4429 hu(i,j) = (h_node(i,j) * cs%u_shelf(i,j))
4430 endif
4431 if (cs%vmask(i,j) > 0) then
4432 hv(i,j) = (h_node(i,j) * cs%v_shelf(i,j))
4433 endif
4434 enddo ; enddo
4435
4436 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4437 if ((iss%hmask(i,j) == 1) .or. (iss%hmask(i,j) == 3)) then
4438 !components of flux divergence at cell centers
4439 hux(i,j) = (((hu(i-1,j-1) * cs%PhiC(1,i,j)) + (hu(i,j ) * cs%PhiC(7,i,j))) + &
4440 ((hu(i-1,j ) * cs%PhiC(5,i,j)) + (hu(i,j-1) * cs%PhiC(3,i,j))))
4441
4442 hvy(i,j) = (((hv(i-1,j-1) * cs%PhiC(2,i,j)) + (hv(i,j ) * cs%PhiC(8,i,j))) + &
4443 ((hv(i-1,j ) * cs%PhiC(6,i,j)) + (hv(i,j-1) * cs%PhiC(4,i,j))))
4444 flux_div(i,j) = hux(i,j) + hvy(i,j)
4445 endif
4446 enddo ; enddo
4447
4448 if (cs%id_duHdx > 0) call post_data(cs%id_duHdx, hux, cs%diag)
4449 if (cs%id_dvHdy > 0) call post_data(cs%id_dvHdy, hvy, cs%diag)
4450 if (cs%id_fluxdiv > 0) call post_data(cs%id_fluxdiv, flux_div, cs%diag)
4451 endif
4452
4453 if (cs%id_devstress_xx > 0 .or. cs%id_devstress_yy > 0 .or. cs%id_devstress_xy > 0 .or. &
4454 cs%id_strainrate_xx > 0 .or. cs%id_strainrate_yy > 0 .or. cs%id_strainrate_xy > 0 .or. &
4455 cs%id_pdevstress_1 > 0 .or. cs%id_pdevstress_2 > 0 .or. &
4456 cs%id_pstrainrate_1 > 0 .or. cs%id_pstrainrate_2 > 0) then
4457
4458 strain_rate(:,:,:) = 0.0
4459 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4460 !strain-rates at cell centers
4461 if ((iss%hmask(i,j) == 1) .or. (iss%hmask(i,j) == 3)) then
4462 !strain_rate(:,:,1) = strain_rate_xx(:,:) = ux(:,:)
4463 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))) + &
4464 ((cs%u_shelf(i-1,j ) * cs%PhiC(5,i,j)) + (cs%u_shelf(i,j-1) * cs%PhiC(3,i,j))))
4465 !strain_rate(:,:,2) = strain_rate_yy(:,:) = uy(:,:)
4466 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))) + &
4467 ((cs%v_shelf(i-1,j ) * cs%PhiC(6,i,j)) + (cs%v_shelf(i,j-1) * cs%PhiC(4,i,j))))
4468 !strain_rate(:,:,3) = strain_rate_xy(:,:) = 0.5 * (uy(:,:) + vy(:,:))
4469 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))) + &
4470 ((cs%u_shelf(i-1,j ) * cs%PhiC(6,i,j)) + (cs%u_shelf(i,j-1) * cs%PhiC(4,i,j))))+ &
4471 (((cs%v_shelf(i-1,j-1) * cs%PhiC(1,i,j)) + (cs%v_shelf(i,j ) * cs%PhiC(7,i,j))) + &
4472 ((cs%v_shelf(i-1,j ) * cs%PhiC(5,i,j)) + (cs%v_shelf(i,j-1) * cs%PhiC(3,i,j)))))
4473 endif
4474 enddo ; enddo
4475
4476
4477 if (cs%id_strainrate_xx > 0) call post_data(cs%id_strainrate_xx, strain_rate(:,:,1), cs%diag)
4478 if (cs%id_strainrate_yy > 0) call post_data(cs%id_strainrate_yy, strain_rate(:,:,2), cs%diag)
4479 if (cs%id_strainrate_xy > 0) call post_data(cs%id_strainrate_xy, strain_rate(:,:,3), cs%diag)
4480
4481 if (cs%id_pstrainrate_1 > 0 .or. cs%id_pstrainrate_2 > 0 .or. &
4482 cs%id_pdevstress_1 > 0 .or. cs%id_pdevstress_2 > 0) then
4483 p_strain_rate(:,:,:) = 0.0
4484 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4485 p1 = 0.5*( strain_rate(i,j,1) + strain_rate(i,j,2))
4486 p2 = sqrt( (( 0.5 * (strain_rate(i,j,1) - strain_rate(i,j,2)) )**2) + (strain_rate(i,j,3)**2) )
4487 p_strain_rate(i,j,1) = p1+p2 !Max horizontal principal strain-rate
4488 p_strain_rate(i,j,2) = p1-p2 !Min horizontal principal strain-rate
4489 enddo ; enddo
4490
4491 if (cs%id_pstrainrate_1 > 0) call post_data(cs%id_pstrainrate_1, p_strain_rate(:,:,1), cs%diag)
4492 if (cs%id_pstrainrate_2 > 0) call post_data(cs%id_pstrainrate_2, p_strain_rate(:,:,2), cs%diag)
4493 endif
4494
4495 if (cs%id_devstress_xx > 0 .or. cs%id_devstress_yy > 0 .or. cs%id_devstress_xy > 0 .or. &
4496 cs%id_pdevstress_1 > 0 .or. cs%id_pdevstress_2 > 0) then
4497
4498 call ice_visc_diag(cs,g,ice_visc)
4499
4500 if (cs%id_devstress_xx > 0 .or. cs%id_devstress_yy > 0 .or. cs%id_devstress_xy > 0) then
4501 dev_stress(:,:,:)=0.0
4502 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4503 if (iss%h_shelf(i,j)>0) then
4504 dev_stress(i,j,1) = 2*ice_visc(i,j)*strain_rate(i,j,1)/iss%h_shelf(i,j) !deviatoric stress xx
4505 dev_stress(i,j,2) = 2*ice_visc(i,j)*strain_rate(i,j,2)/iss%h_shelf(i,j) !deviatoric stress yy
4506 dev_stress(i,j,3) = 2*ice_visc(i,j)*strain_rate(i,j,3)/iss%h_shelf(i,j) !deviatoric stress xy
4507 endif
4508 enddo ; enddo
4509 if (cs%id_devstress_xx > 0) call post_data(cs%id_devstress_xx, dev_stress(:,:,1), cs%diag)
4510 if (cs%id_devstress_yy > 0) call post_data(cs%id_devstress_yy, dev_stress(:,:,2), cs%diag)
4511 if (cs%id_devstress_xy > 0) call post_data(cs%id_devstress_xy, dev_stress(:,:,3), cs%diag)
4512 endif
4513
4514 if (cs%id_pdevstress_1 > 0 .or. cs%id_pdevstress_2 > 0) then
4515 p_dev_stress(:,:,:)=0.0
4516 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4517 if (iss%h_shelf(i,j)>0) then
4518 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
4519 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
4520 endif
4521 enddo ; enddo
4522 if (cs%id_pdevstress_1 > 0) call post_data(cs%id_pdevstress_1, p_dev_stress(:,:,1), cs%diag)
4523 if (cs%id_pdevstress_2 > 0) call post_data(cs%id_pdevstress_2, p_dev_stress(:,:,2), cs%diag)
4524 endif
4525 endif
4526 endif
4527end subroutine is_dynamics_post_data_2
4528
4529!> Update depth integrated viscosity, based on horizontal strain rates
4530subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
4531 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
4532 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
4533 !! the ice-shelf state
4534 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4535 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
4536 real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
4537 intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1].
4538 real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
4539 intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1].
4540
4541! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve
4542
4543
4544! this may be subject to change later... to make it "hybrid"
4545! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy
4546 integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq
4547 integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js
4548 real :: Visc_coef, n_g
4549 real :: ux, uy, vx, vy
4550 real :: eps_min ! Velocity shears [T-1 ~> s-1]
4551 real :: In_g ! inverse of Glen's exponent [nondim]
4552 real :: eps_e2_exp ! (1.-n_g)/(2.*n_g) [nondim]
4553 logical :: model_qp1, model_qp4
4554
4555 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
4556 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
4557 isd = g%isd ; jsd = g%jsd ; ied = g%ied ; jed = g%jed
4558 iegq = g%iegB ; jegq = g%jegB
4559 gisc = g%domain%nihalo+1 ; gjsc = g%domain%njhalo+1
4560 giec = g%domain%niglobal+gisc ; gjec = g%domain%njglobal+gjsc
4561 is = iscq - 1 ; js = jscq - 1
4562
4563 if (trim(cs%ice_viscosity_compute) == "MODEL") then
4564 if (cs%visc_qps==1) then
4565 model_qp1=.true.
4566 model_qp4=.false.
4567 else
4568 model_qp1=.false.
4569 model_qp4=.true.
4570 endif
4571 endif
4572
4573 n_g = cs%n_glen ; eps_min = cs%eps_glen_min
4574 in_g=1./n_g
4575 eps_e2_exp=(1.-n_g)/(2.*n_g)
4576
4577 do j=jsc,jec ; do i=isc,iec
4578
4579 if ((iss%hmask(i,j) == 1) .OR. (iss%hmask(i,j) == 3)) then
4580
4581 if (trim(cs%ice_viscosity_compute) == "CONSTANT") then
4582 cs%ice_visc(i,j,1) = 1e15 * (us%kg_m3_to_R*us%m_to_L*us%m_s_to_L_T) * &
4583 (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf))
4584 ! constant viscocity for debugging
4585 elseif (trim(cs%ice_viscosity_compute) == "OBS") then
4586 if (cs%AGlen_visc(i,j) >0) then
4587 cs%ice_visc(i,j,1) = (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf)) * &
4588 max(cs%AGlen_visc(i,j) ,cs%min_ice_visc)
4589 endif
4590 ! Here CS%Aglen_visc(i,j) is the ice viscosity [R L2 T-1 ~> Pa s] computed from obs and read from a file
4591 elseif (model_qp1) then
4592 ! calculate viscosity at 1 cell-centered quadrature point per cell
4593
4594 visc_coef = (cs%AGlen_visc(i,j))**(-in_g)
4595 ! Units of Aglen_visc [Pa-(n_g) s-1]
4596
4597 ux = ((u_shlf(i-1,j-1) * cs%PhiC(1,i,j)) + &
4598 (u_shlf(i,j) * cs%PhiC(7,i,j))) + &
4599 ((u_shlf(i-1,j) * cs%PhiC(5,i,j)) + &
4600 (u_shlf(i,j-1) * cs%PhiC(3,i,j)))
4601
4602 vx = ((v_shlf(i-1,j-1) * cs%PhiC(1,i,j)) + &
4603 (v_shlf(i,j) * cs%PhiC(7,i,j))) + &
4604 ((v_shlf(i-1,j) * cs%PhiC(5,i,j)) + &
4605 (v_shlf(i,j-1) * cs%PhiC(3,i,j)))
4606
4607 uy = ((u_shlf(i-1,j-1) * cs%PhiC(2,i,j)) + &
4608 (u_shlf(i,j) * cs%PhiC(8,i,j))) + &
4609 ((u_shlf(i-1,j) * cs%PhiC(6,i,j)) + &
4610 (u_shlf(i,j-1) * cs%PhiC(4,i,j)))
4611
4612 vy = ((v_shlf(i-1,j-1) * cs%PhiC(2,i,j)) + &
4613 (v_shlf(i,j) * cs%PhiC(8,i,j))) + &
4614 ((v_shlf(i-1,j) * cs%PhiC(6,i,j)) + &
4615 (v_shlf(i,j-1) * cs%PhiC(4,i,j)))
4616
4617 cs%ice_visc(i,j,1) = (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf)) * &
4618 max(0.5 * visc_coef * &
4619 (us%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**(eps_e2_exp) * &
4620 (us%Pa_to_RL2_T2*us%s_to_T),cs%min_ice_visc) ! Rescale after the fractional power law.
4621 ! Store Newton tangent stiffness data: strain rates and coefficient for Newton iterations.
4622 ! The Newton correction coefficient is (1/n-1) * ice_visc / eps_e2,
4623 ! where eps_e2 = ux^2 + vy^2 + ux*vy + (uy+vx)^2/4 + eps_min^2 [T-2].
4624 ! It is zero where ice_visc is limited by min_ice_visc (viscosity is not smooth there).
4625 cs%newton_str_ux(i,j,1) = ux ; cs%newton_str_vy(i,j,1) = vy
4626 cs%newton_str_sh(i,j,1) = uy + vx
4627 cs%newton_visc_factor(i,j,1) = 0.0
4628 if (cs%ice_visc(i,j,1) > cs%min_ice_visc * (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf))) then
4629 cs%newton_visc_factor(i,j,1) = ((in_g - 1.) / &
4630 (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * &
4631 cs%ice_visc(i,j,1)
4632 endif
4633 elseif (model_qp4) then
4634 !calculate viscosity at 4 quadrature points per cell
4635 visc_coef = (cs%AGlen_visc(i,j))**(-in_g)
4636
4637 do iq=1,2 ; do jq=1,2
4638
4639 ux = ((u_shlf(i-1,j-1) * cs%Phi(1,2*(jq-1)+iq,i,j)) + &
4640 (u_shlf(i,j) * cs%Phi(7,2*(jq-1)+iq,i,j))) + &
4641 ((u_shlf(i,j-1) * cs%Phi(3,2*(jq-1)+iq,i,j)) + &
4642 (u_shlf(i-1,j) * cs%Phi(5,2*(jq-1)+iq,i,j)))
4643
4644 vx = ((v_shlf(i-1,j-1) * cs%Phi(1,2*(jq-1)+iq,i,j)) + &
4645 (v_shlf(i,j) * cs%Phi(7,2*(jq-1)+iq,i,j))) + &
4646 ((v_shlf(i,j-1) * cs%Phi(3,2*(jq-1)+iq,i,j)) + &
4647 (v_shlf(i-1,j) * cs%Phi(5,2*(jq-1)+iq,i,j)))
4648
4649 uy = ((u_shlf(i-1,j-1) * cs%Phi(2,2*(jq-1)+iq,i,j)) + &
4650 (u_shlf(i,j) * cs%Phi(8,2*(jq-1)+iq,i,j))) + &
4651 ((u_shlf(i,j-1) * cs%Phi(4,2*(jq-1)+iq,i,j)) + &
4652 (u_shlf(i-1,j) * cs%Phi(6,2*(jq-1)+iq,i,j)))
4653
4654 vy = ((v_shlf(i-1,j-1) * cs%Phi(2,2*(jq-1)+iq,i,j)) + &
4655 (v_shlf(i,j) * cs%Phi(8,2*(jq-1)+iq,i,j))) + &
4656 ((v_shlf(i,j-1) * cs%Phi(4,2*(jq-1)+iq,i,j)) + &
4657 (v_shlf(i-1,j) * cs%Phi(6,2*(jq-1)+iq,i,j)))
4658
4659 cs%ice_visc(i,j,2*(jq-1)+iq) = (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf)) * &
4660 max(0.5 * visc_coef * &
4661 (us%s_to_T**2*(((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**(eps_e2_exp) * &
4662 (us%Pa_to_RL2_T2*us%s_to_T),cs%min_ice_visc) ! Rescale after the fractional power law.
4663 ! Store Newton tangent stiffness data at each quadrature point.
4664 cs%newton_str_ux(i,j,2*(jq-1)+iq) = ux ; cs%newton_str_vy(i,j,2*(jq-1)+iq) = vy
4665 cs%newton_str_sh(i,j,2*(jq-1)+iq) = (uy + vx)
4666 cs%newton_visc_factor(i,j,2*(jq-1)+iq) = 0.0
4667 if (cs%ice_visc(i,j,2*(jq-1)+iq) > &
4668 cs%min_ice_visc * (g%areaT(i,j) * max(iss%h_shelf(i,j),cs%min_h_shelf))) then
4669 cs%newton_visc_factor(i,j,2*(jq-1)+iq) = ((in_g - 1.) / &
4670 (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * &
4671 cs%ice_visc(i,j,2*(jq-1)+iq)
4672 endif
4673 enddo ; enddo
4674 endif
4675 endif
4676 enddo ; enddo
4677
4678end subroutine calc_shelf_visc
4679
4680!> Pre-compute element-level basal friction prefactors for quadrature-point evaluation.
4681subroutine calc_shelf_basal_prefactors(CS, ISS, G, US)
4682 type(ice_shelf_dyn_cs), intent(inout) :: CS !< Ice shelf dynamics control structure
4683 type(ice_shelf_state), intent(in) :: ISS !< Ice shelf state (hmask, h_shelf)
4684 type(ocean_grid_type), intent(in) :: G !< The grid structure
4685 type(unit_scale_type), intent(in) :: US !< Unit conversion factors
4686
4687 integer :: i, j, isd, ied, jsd, jed
4688 real :: Hf ! Floatation thickness [Z ~> m]
4689 real :: fN ! Effective pressure for Coulomb friction [R Z L T-2 ~> Pa]
4690
4691 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
4692
4693 do j = jsd, jed ; do i = isd, ied
4694 cs%coef_prefactor(i,j) = g%areaT(i,j) * cs%C_basal_friction(i,j) * us%L_T_to_m_s
4695 if (cs%CoulombFriction .and. (iss%hmask(i,j) == 1 .or. iss%hmask(i,j) == 3)) then
4696 hf = max(cs%rhow_rhoi * cs%bed_elev(i,j), 0.0)
4697 fn = max((us%L_to_Z*(cs%density_ice * cs%g_Earth) * &
4698 (max(iss%h_shelf(i,j), cs%min_h_shelf) - hf)), cs%CF_MinN)
4699 cs%fB_elem(i,j) = cs%alpha_coulomb * &
4700 (cs%C_basal_friction(i,j) / (cs%CF_Max * fn))**(cs%coulomb_pp_n)
4701 else
4702 cs%fB_elem(i,j) = 0.0
4703 endif
4704 enddo ; enddo
4705
4706end subroutine calc_shelf_basal_prefactors
4707
4708!> Compute basal traction coefficient beta = taub/|u| [R Z T-1 ~> Pa s m-1]
4709!! Basal shear stress = beta * ice speed
4710subroutine calc_shelf_taub(CS, ISS, G, basal_tr)
4711 type(ice_shelf_dyn_cs), intent(in) :: CS !< Ice shelf dynamics control structure
4712 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
4713 !! the ice-shelf state
4714 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4715 real, dimension(SZDI_(G),SZDJ_(G)), &
4716 intent(out) :: basal_tr !< Basal traction coefficient, taub/|u|
4717 !! [R Z T-1 ~> Pa s m-1]
4718
4719 integer :: i, j
4720 real :: umid, vmid ! Cell-center velocity averages [L T-1 ~> m s-1]
4721 real :: eps_min ! Minimal strain rate [T-1 ~> s-1]
4722 real :: unorm ! Velocity magnitude in mks units [m s-1]
4723 real :: Hf ! Floatation thickness for Coulomb friction [Z ~> m]
4724 real :: fN ! Effective pressure for Coulomb friction [R Z L T-2 ~> Pa]
4725 real :: fB ! Coulomb friction factor [(s m-1)^CS%CF_PostPeak]
4726 real :: fBuq ! fB * unorm^CF_PostPeak [nondim]
4727 real :: unorm_code2 ! Squared velocity magnitude in code units [L2 T-2 ~> m2 s-2]
4728 real :: basal_trac ! Area-integrated traction coefficient [R Z L2 T-1 ~> kg s-1]
4729
4730 eps_min = cs%eps_glen_min
4731
4732 basal_tr(:,:) = 0.0
4733
4734 ! For simplicity, the diagnostic is calculated here at cell center, so it will differ slightly from
4735 ! the solver if the solver uses 4 quadrature points.
4736 do j=g%jsc,g%jec ; do i=g%isc,g%iec
4737 if ((iss%hmask(i,j) == 1) .OR. (iss%hmask(i,j) == 3)) then
4738 umid = ((cs%u_shelf(i,j) + cs%u_shelf(i-1,j-1)) + (cs%u_shelf(i,j-1) + cs%u_shelf(i-1,j))) * 0.25
4739 vmid = ((cs%v_shelf(i,j) + cs%v_shelf(i-1,j-1)) + (cs%v_shelf(i,j-1) + cs%v_shelf(i-1,j))) * 0.25
4740 unorm_code2 = ((umid**2) + (vmid**2)) + (eps_min**2 * ((g%dxT(i,j)**2) + (g%dyT(i,j)**2)))
4741 unorm = g%US%L_T_to_m_s * sqrt(unorm_code2)
4742
4743 ! Recalculate fB and areaT * C_basal_friction here because CS%fB_elem and CS%coef_prefactor are not
4744 ! updated before the first solve or on steps that skip the velocity update.
4745 if (cs%CoulombFriction) then
4746 !(Schoof 2005, Gagliardini et al 2007)
4747 !Effective pressure
4748 hf = max(cs%rhow_rhoi * cs%bed_elev(i,j), 0.0)
4749 fn = max((g%US%L_to_Z*(cs%density_ice * cs%g_Earth) * (max(iss%h_shelf(i,j),cs%min_h_shelf) - hf)), cs%CF_MinN)
4750 fb = cs%alpha_coulomb * (cs%C_basal_friction(i,j) / (cs%CF_Max * fn))**(cs%coulomb_pp_n)
4751 fbuq = fb * unorm**cs%CF_PostPeak
4752 basal_trac = ((g%areaT(i,j) * cs%C_basal_friction(i,j)) * &
4753 (unorm**(cs%n_basal_fric-1.0) / (1.0 + fbuq)**(cs%n_basal_fric))) * &
4754 g%US%L_T_to_m_s ! Restore the scaling after the fractional power law.
4755 else
4756 !linear (CS%n_basal_fric = 1) or "Weertman"/power-law (CS%n_basal_fric /= 1)
4757 basal_trac = ((g%areaT(i,j) * cs%C_basal_friction(i,j)) * (unorm**(cs%n_basal_fric-1.0))) * &
4758 g%US%L_T_to_m_s ! Rescale after the fractional power law.
4759 endif
4760
4761 basal_trac = max(basal_trac, cs%min_basal_traction * g%areaT(i,j))
4762 basal_tr(i,j) = basal_trac * g%IareaT(i,j) * cs%ground_frac(i,j)
4763 endif
4764 enddo ; enddo
4765
4766end subroutine calc_shelf_taub
4767
4768subroutine update_od_ffrac(CS, G, US, ocean_mass, find_avg)
4769 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
4770 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
4771 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
4772 real, dimension(SZDI_(G),SZDJ_(G)), &
4773 intent(in) :: ocean_mass !< The mass per unit area of the ocean [R Z ~> kg m-2].
4774 logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and
4775 !! reset the underlying running sums to 0.
4776
4777 integer :: isc, iec, jsc, jec, i, j
4778 real :: I_rho_ocean ! A typical specific volume of the ocean [R-1 ~> m3 kg-1]
4779 real :: I_counter
4780
4781 i_rho_ocean = 1.0 / cs%density_ocean_avg
4782
4783 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
4784
4785 do j=jsc,jec ; do i=isc,iec
4786 cs%OD_rt(i,j) = cs%OD_rt(i,j) + ocean_mass(i,j)*i_rho_ocean
4787 if (ocean_mass(i,j)*i_rho_ocean > cs%thresh_float_col_depth) then
4788 cs%ground_frac_rt(i,j) = cs%ground_frac_rt(i,j) + 1.0
4789 endif
4790 enddo ; enddo
4791 cs%OD_rt_counter = cs%OD_rt_counter + 1
4792
4793 if (find_avg) then
4794 i_counter = 1.0 / real(cs%OD_rt_counter)
4795 do j=jsc,jec ; do i=isc,iec
4796 cs%ground_frac(i,j) = 1.0 - (cs%ground_frac_rt(i,j) * i_counter)
4797 cs%OD_av(i,j) = cs%OD_rt(i,j) * i_counter
4798
4799 cs%OD_rt(i,j) = 0.0 ; cs%ground_frac_rt(i,j) = 0.0 ; cs%OD_rt_counter = 0
4800 enddo ; enddo
4801
4802 call pass_var(cs%ground_frac, g%domain, complete=.false.)
4803 call pass_var(cs%OD_av, g%domain, complete=.true.)
4804 endif
4805
4806end subroutine update_od_ffrac
4807
4808subroutine update_od_ffrac_uncoupled(CS, G, h_shelf)
4809 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
4810 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4811 real, dimension(SZDI_(G),SZDJ_(G)), &
4812 intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m].
4813
4814 integer :: i, j, isd, ied, jsd, jed
4815 real :: OD
4816
4817 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
4818
4819 do j=jsd,jed
4820 do i=isd,ied
4821 od = cs%bed_elev(i,j) - cs%rhoi_rhow * max(h_shelf(i,j),cs%min_h_shelf)
4822 if (od >= 0) then
4823 ! ice thickness does not take up whole ocean column -> floating
4824 cs%OD_av(i,j) = od
4825 cs%ground_frac(i,j) = 0.
4826 else
4827 cs%OD_av(i,j) = 0.
4828 cs%ground_frac(i,j) = 1.
4829 endif
4830 enddo
4831 enddo
4832
4833end subroutine update_od_ffrac_uncoupled
4834
4835subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft)
4836 type(ice_shelf_dyn_cs), intent(inout) :: cs !< A pointer to the ice shelf control structure
4837 type(ocean_grid_type), intent(in) :: g !< The grid structure used by the ice shelf.
4838 real, dimension(SZDI_(G),SZDJ_(G)), &
4839 intent(in) :: h_shelf0 !< the previous thickness of the ice shelf [Z ~> m].
4840 real, dimension(SZDI_(G),SZDJ_(G)), &
4841 intent(in) :: h_shelf1 !< the current thickness of the ice shelf [Z ~> m].
4842 real, dimension(SZDI_(G),SZDJ_(G)), &
4843 intent(inout) :: ddraft !< the change in shelf draft thickness
4844 real :: b0, b1
4845 integer :: i, j, isc, iec, jsc, jec
4846 real :: od
4847
4848 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
4849 ddraft = 0.0
4850
4851 do j=jsc,jec
4852 do i=isc,iec
4853
4854 b0 = 0.0 ; b1 = 0.0
4855
4856 if (h_shelf0(i,j)>0.0) then
4857 od = cs%bed_elev(i,j) - cs%rhoi_rhow * h_shelf0(i,j)
4858 if (od >= 0) then
4859 !floating
4860 b0 = cs%rhoi_rhow * h_shelf0(i,j)
4861 else
4862 b0 = cs%bed_elev(i,j)
4863 endif
4864 endif
4865
4866 if (h_shelf1(i,j)>0.0) then
4867 od = cs%bed_elev(i,j) - cs%rhoi_rhow * h_shelf1(i,j)
4868 if (od >= 0) then
4869 !floating
4870 b1 = cs%rhoi_rhow * h_shelf1(i,j)
4871 else
4872 b1 = cs%bed_elev(i,j)
4873 endif
4874 endif
4875
4876 ddraft(i,j) = b1-b0
4877 enddo
4878 enddo
4879end subroutine change_in_draft
4880
4881!> This subroutine calculates the gradients of bilinear basis elements that
4882!! that are centered at the vertices of the cell. Values are calculated at
4883!! points of gaussian quadrature.
4884subroutine bilinear_shape_functions (X, Y, Phi, area)
4885 real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m].
4886 real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m].
4887 real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian
4888 !! quadrature points surrounding the cell vertices [L-1 ~> m-1].
4889 real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2].
4890
4891! X and Y must be passed in the form
4892 ! 3 - 4
4893 ! | |
4894 ! 1 - 2
4895
4896! this subroutine calculates the gradients of bilinear basis elements that
4897! that are centered at the vertices of the cell. values are calculated at
4898! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1])
4899! (ordered in same way as vertices)
4900!
4901! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j
4902! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j
4903! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear
4904!
4905! This should be a one-off; once per nonlinear solve? once per lifetime?
4906! ... will all cells have the same shape and dimension?
4907
4908 real, dimension(4) :: xquad, yquad ! [nondim]
4909 real :: a, b, c, d ! Various lengths [L ~> m]
4910 real :: xexp, yexp ! [nondim]
4911 integer :: node, qpoint, xnode, ynode
4912
4913 xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3))
4914 xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3))
4915
4916 do qpoint=1,4
4917
4918 a = ((-x(1)*(1-yquad(qpoint)))+(x(4)*yquad(qpoint))) + ((x(2)*(1-yquad(qpoint)))-(x(3)*yquad(qpoint))) !d(x)/d(x*)
4919 b = ((-y(1)*(1-yquad(qpoint)))+(y(4)*yquad(qpoint))) + ((y(2)*(1-yquad(qpoint)))-(y(3)*yquad(qpoint))) !d(y)/d(x*)
4920 c = ((-x(1)*(1-xquad(qpoint)))+(x(4)*xquad(qpoint))) + ((-x(2)*xquad(qpoint))+(x(3)*(1-xquad(qpoint))))!d(x)/d(y*)
4921 d = ((-y(1)*(1-xquad(qpoint)))+(y(4)*xquad(qpoint))) + ((-y(2)*xquad(qpoint))+(y(3)*(1-xquad(qpoint))))!d(y)/d(y*)
4922
4923 do node=1,4
4924
4925 xnode = 2-mod(node,2) ; ynode = ceiling(real(node)/2)
4926
4927 if (ynode == 1) then
4928 yexp = 1-yquad(qpoint)
4929 else
4930 yexp = yquad(qpoint)
4931 endif
4932
4933 if (1 == xnode) then
4934 xexp = 1-xquad(qpoint)
4935 else
4936 xexp = xquad(qpoint)
4937 endif
4938
4939 phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / ((a*d)-(b*c))
4940 phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / ((a*d)-(b*c))
4941
4942 enddo
4943 enddo
4944
4945 area = quad_area(x, y)
4946
4947end subroutine bilinear_shape_functions
4948
4949!> This subroutine calculates the gradients of bilinear basis elements that are centered at the
4950!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at
4951!! points of gaussian quadrature.
4952subroutine bilinear_shape_fn_grid(G, i, j, Phi, Jac)
4953 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
4954 integer, intent(in) :: i !< The i-index in the grid to work on.
4955 integer, intent(in) :: j !< The j-index in the grid to work on.
4956 real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian
4957 !! quadrature points surrounding the cell vertices [L-1 ~> m-1].
4958 real, dimension(4), optional, intent(out) :: Jac !< Jacobian determinant |J_q| = a_q*d_q at each
4959 !! Gaussian quadrature point [L2 ~> m2].
4960
4961! This subroutine calculates the gradients of bilinear basis elements that
4962! that are centered at the vertices of the cell. The values are calculated at
4963! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1])
4964! (ordered in same way as vertices)
4965!
4966! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j
4967! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j
4968! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear
4969!
4970! This should be a one-off; once per nonlinear solve? once per lifetime?
4971
4972 real, dimension(4) :: xquad, yquad ! [nondim]
4973 ! Mirror lookups: xquad_m(qp) == 1 - xquad(qp), yquad_m(qp) == 1 - yquad(qp) mathematically,
4974 ! but each mirror entry is the stored value at the x- or y-mirrored quadrature point. This
4975 ! ensures rotation-paired QPs read bit-identical operand values.
4976 real, dimension(4) :: xquad_m, yquad_m ! Mirrors of xquad, yquad [nondim]
4977 real :: a, d ! Interpolated grid spacings [L ~> m]
4978 real :: xexp, yexp ! [nondim]
4979 integer :: node, qpoint, xnode, ynode
4980
4981 xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3))
4982 xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3))
4983
4984 ! x-mirror swaps qp 1<->2 and 3<->4; y-mirror swaps 1<->3 and 2<->4
4985 xquad_m(1) = xquad(2) ; xquad_m(2) = xquad(1) ; xquad_m(3) = xquad(4) ; xquad_m(4) = xquad(3)
4986 yquad_m(1) = yquad(3) ; yquad_m(2) = yquad(4) ; yquad_m(3) = yquad(1) ; yquad_m(4) = yquad(2)
4987
4988 do qpoint=1,4
4989 if (j>1) then
4990 a = (g%dxCv(i,j-1) * yquad_m(qpoint)) + (g%dxCv(i,j) * yquad(qpoint)) ! d(x)/d(x*)
4991 else
4992 a = g%dxCv(i,j) !* yquad(qpoint) ! d(x)/d(x*)
4993 endif
4994 if (i>1) then
4995 d = (g%dyCu(i-1,j) * xquad_m(qpoint)) + (g%dyCu(i,j) * xquad(qpoint)) ! d(y)/d(y*)
4996 else
4997 d = g%dyCu(i,j) !* xquad(qpoint)
4998 endif
4999
5000 do node=1,4
5001 xnode = 2-mod(node,2) ; ynode = ceiling(real(node)/2)
5002
5003 if (ynode == 1) then
5004 yexp = yquad_m(qpoint)
5005 else
5006 yexp = yquad(qpoint)
5007 endif
5008
5009 if (1 == xnode) then
5010 xexp = xquad_m(qpoint)
5011 else
5012 xexp = xquad(qpoint)
5013 endif
5014
5015 phi(2*node-1,qpoint) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d)
5016 phi(2*node,qpoint) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d)
5017
5018 enddo
5019 if (present(jac)) jac(qpoint) = a * d
5020 enddo
5021
5022end subroutine bilinear_shape_fn_grid
5023
5024!> This subroutine calculates the gradients of bilinear basis elements that are centered at the
5025!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at
5026!! a sinlge cell-centered quadrature point, which should match the grid cell h-point
5027subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi)
5028 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
5029 integer, intent(in) :: i !< The i-index in the grid to work on.
5030 integer, intent(in) :: j !< The j-index in the grid to work on.
5031 real, dimension(8), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian
5032 !! quadrature points surrounding the cell vertices [L-1 ~> m-1].
5033
5034! This subroutine calculates the gradients of bilinear basis elements that
5035! that are centered at the vertices of the cell. The values are calculated at
5036! a cell-cented point of gaussian quadrature. (in 1D: .5 for [0,1])
5037! (ordered in same way as vertices)
5038!
5039! Phi(2*i-1) gives d(Phi_i)/dx at the quadrature point
5040! Phi(2*i) gives d(Phi_i)/dy at the quadrature point
5041! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear
5042
5043 real :: a, d ! Interpolated grid spacings [L ~> m]
5044 real :: xexp=0.5, yexp=0.5 ! [nondim]
5045 integer :: node, qpoint, xnode, ynode
5046
5047 ! d(x)/d(x*)
5048 if (j>1) then
5049 a = 0.5 * (g%dxCv(i,j-1) + g%dxCv(i,j))
5050 else
5051 a = g%dxCv(i,j)
5052 endif
5053
5054 ! d(y)/d(y*)
5055 if (i>1) then
5056 d = 0.5 * (g%dyCu(i-1,j) + g%dyCu(i,j))
5057 else
5058 d = g%dyCu(i,j)
5059 endif
5060
5061 do node=1,4
5062 xnode = 2-mod(node,2) ; ynode = ceiling(real(node)/2)
5063 phi(2*node-1) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d)
5064 phi(2*node) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d)
5065 enddo
5066end subroutine bilinear_shape_fn_grid_1qp
5067
5068
5069subroutine bilinear_shape_functions_subgrid(Phisub, nsub)
5070 integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction
5071 real, dimension(2,2,nsub,nsub,2,2), &
5072 intent(inout) :: Phisub !< Quadrature structure weights at subgridscale
5073 !! locations for finite element calculations [nondim]
5074
5075 ! this subroutine is a helper for interpolation of floatation condition
5076 ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is
5077 ! in partial floatation
5078 ! the array Phisub contains the values of \phi_i (where i is a node of the cell)
5079 ! at quad point j
5080 ! i think this general approach may not work for nonrectangular elements...
5081 !
5082
5083 ! Phisub(q1,q2,i,j,k,l)
5084 ! q1: quad point x-index
5085 ! q2: quad point y-index
5086 ! i: subgrid index in x-direction
5087 ! j: subgrid index in y-direction
5088 ! k: basis function x-index
5089 ! l: basis function y-index
5090
5091 ! e.g. k=1,l=1 => node 1
5092 ! q1=2,q2=1 => quad point 2
5093
5094 ! 3 - 4
5095 ! | |
5096 ! 1 - 2
5097
5098 integer :: i, j, qx, qy
5099 real,dimension(2) :: xquad ! [nondim]
5100 real :: fracx ! The fractional sub-cell area in reference space [nondim]
5101 ! Mirror-symmetric per-direction node weights: a_left == 1-x_global, a_right == x_global
5102 ! mathematically, but constructed so that a_right(qx,i) is computed by exactly the same
5103 ! operand sequence as a_left(3-qx, nsub+1-i). This guarantees bit-exact rotation symmetry.
5104 real, dimension(2,nsub) :: a_left, a_right ! [nondim]
5105
5106 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
5107 fracx = 1.0/real(nsub)
5108
5109 do i=1,nsub ; do qx=1,2
5110 a_left(qx,i) = (real(nsub-i) + xquad(3-qx)) * fracx
5111 a_right(qx,i) = (real(i-1) + xquad(qx)) * fracx
5112 enddo ; enddo
5113
5114 do j=1,nsub ; do i=1,nsub
5115 do qy=1,2 ; do qx=1,2
5116 phisub(qx,qy,i,j,1,1) = a_left(qx,i) * a_left(qy,j)
5117 phisub(qx,qy,i,j,1,2) = a_left(qx,i) * a_right(qy,j)
5118 phisub(qx,qy,i,j,2,1) = a_right(qx,i) * a_left(qy,j)
5119 phisub(qx,qy,i,j,2,2) = a_right(qx,i) * a_right(qy,j)
5120 enddo ; enddo
5121 enddo ; enddo
5122
5124
5125
5126subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask)
5127 type(ice_shelf_dyn_cs),intent(in) :: CS !< A pointer to the ice shelf dynamics control structure
5128 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
5129 real, dimension(SZDI_(G),SZDJ_(G)), &
5130 intent(in) :: hmask !< A mask indicating which tracer points are
5131 !! partly or fully covered by an ice-shelf
5132 real, dimension(SZDIB_(G),SZDJB_(G)), &
5133 intent(out) :: umask !< A coded mask indicating the nature of the
5134 !! zonal flow at the corner point
5135 real, dimension(SZDIB_(G),SZDJB_(G)), &
5136 intent(out) :: vmask !< A coded mask indicating the nature of the
5137 !! meridional flow at the corner point
5138 real, dimension(SZDIB_(G),SZDJB_(G)), &
5139 intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face
5140 real, dimension(SZDIB_(G),SZDJB_(G)), &
5141 intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face
5142 ! sets masks for velocity solve
5143 ! ignores the fact that their might be ice-free cells - this only considers the computational boundary
5144
5145 ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated
5146
5147 integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq
5148 integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec
5149
5150 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
5151 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
5152 isd = g%isd ; jsd = g%jsd
5153 iegq = g%iegB ; jegq = g%jegB
5154 gisc = g%Domain%nihalo ; gjsc = g%Domain%njhalo
5155 giec = g%Domain%niglobal+gisc ; gjec = g%Domain%njglobal+gjsc
5156
5157 umask(:,:) = 0 ; vmask(:,:) = 0
5158 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0
5159
5160 if (g%symmetric) then
5161 is = isd ; js = jsd
5162 else
5163 is = isd+1 ; js = jsd+1
5164 endif
5165
5166 do j=js,g%jed ; do i=is,g%ied
5167 if (hmask(i,j) == 1 .or. hmask(i,j)==3) then
5168 umask(i-1:i,j-1:j)=1
5169 vmask(i-1:i,j-1:j)=1
5170 endif
5171 enddo ; enddo
5172
5173 do j=js,g%jed
5174 do i=is,g%ied
5175
5176 if ((hmask(i,j) == 1) .OR. (hmask(i,j) == 3)) then
5177
5178 do k=0,1
5179
5180 select case (int(cs%u_face_mask_bdry(i-1+k,j)))
5181 case (5)
5182 umask(i-1+k,j-1:j) = 3.
5183 u_face_mask(i-1+k,j) = 5.
5184 case (3)
5185 umask(i-1+k,j-1:j) = 3.
5186 vmask(i-1+k,j-1:j) = 3.
5187 u_face_mask(i-1+k,j) = 3.
5188 case (6)
5189 vmask(i-1+k,j-1:j) = 3.
5190 u_face_mask(i-1+k,j) = 6.
5191 case (2)
5192 u_face_mask(i-1+k,j) = 2.
5193 case (4)
5194 umask(i-1+k,j-1:j) = 0.
5195 u_face_mask(i-1+k,j) = 4.
5196 case (0)
5197 umask(i-1+k,j-1:j) = 0.
5198 u_face_mask(i-1+k,j) = 0.
5199 case (1) ! stress free x-boundary
5200 umask(i-1+k,j-1:j) = 0.
5201 case default
5202 umask(i-1+k,j-1) = max(1. , umask(i-1+k,j-1))
5203 umask(i-1+k,j) = max(1. , umask(i-1+k,j))
5204 end select
5205 enddo
5206
5207 do k=0,1
5208
5209 select case (int(cs%v_face_mask_bdry(i,j-1+k)))
5210 case (5)
5211 vmask(i-1:i,j-1+k) = 3.
5212 v_face_mask(i,j-1+k) = 5.
5213 case (3)
5214 vmask(i-1:i,j-1+k) = 3.
5215 umask(i-1:i,j-1+k) = 3.
5216 v_face_mask(i,j-1+k) = 3.
5217 case (6)
5218 umask(i-1:i,j-1+k) = 3.
5219 v_face_mask(i,j-1+k) = 6.
5220 case (2)
5221 v_face_mask(i,j-1+k) = 2.
5222 case (4)
5223 vmask(i-1:i,j-1+k) = 0.
5224 v_face_mask(i,j-1+k) = 4.
5225 case (0)
5226 vmask(i-1:i,j-1+k) = 0.
5227 v_face_mask(i,j-1+k) = 0.
5228 case (1) ! stress free y-boundary
5229 vmask(i-1:i,j-1+k) = 0.
5230 case default
5231 vmask(i-1,j-1+k) = max(1. , vmask(i-1,j-1+k))
5232 vmask(i,j-1+k) = max(1. , vmask(i,j-1+k))
5233 end select
5234 enddo
5235
5236
5237 if (i < g%ied) then
5238 if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then
5239 ! east boundary or adjacent to unfilled cell
5240 u_face_mask(i,j) = 2.
5241 endif
5242 endif
5243
5244 if (i > g%isd) then
5245 if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then
5246 !adjacent to unfilled cell
5247 u_face_mask(i-1,j) = 2.
5248 endif
5249 endif
5250
5251 if (j > g%jsd) then
5252 if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then
5253 !adjacent to unfilled cell
5254 v_face_mask(i,j-1) = 2.
5255 endif
5256 endif
5257
5258 if (j < g%jed) then
5259 if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then
5260 !adjacent to unfilled cell
5261 v_face_mask(i,j) = 2.
5262 endif
5263 endif
5264
5265
5266 endif
5267
5268 enddo
5269 enddo
5270
5271 ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update
5272 ! so this subroutine must update its own symmetric part of the halo
5273
5274 call pass_vector(u_face_mask, v_face_mask, g%domain, to_all, cgrid_ne)
5275 call pass_vector(umask, vmask, g%domain, to_all, bgrid_ne)
5276
5277end subroutine update_velocity_masks
5278
5279!> Interpolate the ice shelf thickness from tracer point to nodal points,
5280!! subject to a mask.
5281subroutine interpolate_h_to_b(G, h_shelf, hmask, H_node, min_h_shelf)
5282 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
5283 real, dimension(SZDI_(G),SZDJ_(G)), &
5284 intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m].
5285 real, dimension(SZDI_(G),SZDJ_(G)), &
5286 intent(in) :: hmask !< A mask indicating which tracer points are
5287 !! partly or fully covered by an ice-shelf
5288 real, dimension(SZDIB_(G),SZDJB_(G)), &
5289 intent(inout) :: H_node !< The ice shelf thickness at nodal (corner)
5290 !! points [Z ~> m].
5291 real, intent(in) :: min_h_shelf !< The minimum ice thickness used during ice dynamics [Z ~> m].
5292
5293 integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc
5294 real :: h_arr(2,2)
5295
5296 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
5297
5298 h_node(:,:) = 0.0
5299
5300 ! H_node is node-centered; average over all cells that share that node
5301 ! if no (active) cells share the node then its value there is irrelevant
5302
5303 do j=jsc-1,jec
5304 do i=isc-1,iec
5305 num_h = 0
5306 do l=1,2 ; jc=j-1+l ; do k=1,2 ; ic=i-1+k
5307 if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then
5308 h_arr(k,l)=max(h_shelf(ic,jc),min_h_shelf)
5309 num_h = num_h + 1
5310 else
5311 h_arr(k,l)=0.0
5312 endif
5313 if (num_h > 0) then
5314 h_node(i,j) = ((h_arr(1,1)+h_arr(2,2))+(h_arr(1,2)+h_arr(2,1))) / num_h
5315 endif
5316 enddo ; enddo
5317 enddo
5318 enddo
5319
5320 call pass_var(h_node, g%domain,position=corner)
5321
5322end subroutine interpolate_h_to_b
5323
5324!> Deallocates all memory associated with the ice shelf dynamics module
5325subroutine ice_shelf_dyn_end(CS)
5326 type(ice_shelf_dyn_cs), pointer :: cs
5327 !< A pointer to the ice shelf dynamics control structure
5328
5329 logical :: is_open
5330 ! True if CS%fileenergy_ascii is open
5331
5332 if (.not.associated(cs)) return
5333
5334 deallocate(cs%u_shelf, cs%v_shelf)
5335 deallocate(cs%taudx_shelf, cs%taudy_shelf)
5336 deallocate(cs%sx_shelf, cs%sy_shelf)
5337 deallocate(cs%t_shelf, cs%tmask)
5338 deallocate(cs%u_bdry_val, cs%v_bdry_val)
5339 deallocate(cs%u_face_mask, cs%v_face_mask)
5340 deallocate(cs%u_flux_bdry_val, cs%v_flux_bdry_val)
5341 deallocate(cs%umask, cs%vmask)
5342 deallocate(cs%u_face_mask_bdry, cs%v_face_mask_bdry)
5343 deallocate(cs%h_bdry_val)
5344 deallocate(cs%float_cond)
5345 if (associated(cs%calve_mask)) deallocate(cs%calve_mask)
5346
5347 deallocate(cs%ice_visc, cs%AGlen_visc)
5348 deallocate(cs%newton_visc_factor, cs%newton_str_ux, cs%newton_str_vy, cs%newton_str_sh)
5349 deallocate(cs%C_basal_friction)
5350 deallocate(cs%coef_prefactor, cs%fB_elem)
5351 deallocate(cs%OD_rt, cs%OD_av)
5352 deallocate(cs%t_bdry_val, cs%bed_elev)
5353 deallocate(cs%ground_frac, cs%ground_frac_rt)
5354 if (associated(cs%Jac)) deallocate(cs%Jac)
5355 if (associated(cs%Phi)) deallocate(cs%Phi)
5356 if (associated(cs%Phisub)) deallocate(cs%Phisub)
5357 if (associated(cs%PhiC)) deallocate(cs%PhiC)
5358
5359 is_open = .false.
5360 if (cs%IS_fileenergy_ascii /= -1) &
5361 inquire(unit=cs%IS_fileenergy_ascii, opened=is_open)
5362 if (is_open) call close_file(cs%IS_fileenergy_ascii)
5363
5364 deallocate(cs)
5365
5366end subroutine ice_shelf_dyn_end
5367
5368
5369!> This subroutine updates the vertically averaged ice shelf temperature.
5370subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time)
5371 type(ice_shelf_dyn_cs), intent(inout) :: CS !< A pointer to the ice shelf control structure
5372 type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe
5373 !! the ice-shelf state
5374 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
5375 type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
5376 real, intent(in) :: time_step !< The time step for this update [T ~> s].
5377 real, dimension(SZDI_(G),SZDJ_(G)), &
5378 intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1]
5379 type(time_type), intent(in) :: Time !< The current model time
5380
5381! This subroutine takes the velocity (on the Bgrid) and timesteps
5382! (HT)_t = - div (uHT) + (adot Tsurf -bdot Tbot) once and then calculates T=HT/H
5383!
5384! The flux overflows are included here. That is because they will be used to advect 3D scalars
5385! into partial cells
5386
5387 real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH ! Integrated temperatures [C Z ~> degC m]
5388 integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec
5389 real :: Tsurf ! Surface air temperature [C ~> degC]. This is hard coded but should be an input argument.
5390 real :: adot ! A surface heat exchange coefficient [R Z T-1 ~> kg m-2 s-1].
5391
5392
5393 ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later
5394 adot = (0.1/(365.0*86400.0))*us%m_to_Z*us%T_to_s * cs%density_ice
5395 tsurf = -20.0*us%degC_to_C
5396
5397 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
5398 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
5399
5400 th_after_uflux(:,:) = 0.0
5401 th_after_vflux(:,:) = 0.0
5402
5403 do j=jsd,jed ; do i=isd,ied
5404! if (ISS%hmask(i,j) > 1) then
5405 if ((iss%hmask(i,j) == 3) .or. (iss%hmask(i,j) == -2)) then
5406 cs%t_shelf(i,j) = cs%t_bdry_val(i,j)
5407 endif
5408 enddo ; enddo
5409
5410 do j=jsd,jed ; do i=isd,ied
5411 ! Convert the averge temperature to a depth integrated temperature.
5412 th(i,j) = cs%t_shelf(i,j)*iss%h_shelf(i,j)
5413 enddo ; enddo
5414
5415
5416 call ice_shelf_advect_temp_x(cs, g, time_step, iss%hmask, th, th_after_uflux)
5417 call ice_shelf_advect_temp_y(cs, g, time_step, iss%hmask, th_after_uflux, th_after_vflux)
5418
5419 do j=jsc,jec ; do i=isc,iec
5420 ! Convert the integrated temperature back to the average temperature.
5421! if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then
5422 if (iss%h_shelf(i,j) > 0.0) then
5423 cs%t_shelf(i,j) = th_after_vflux(i,j) / iss%h_shelf(i,j)
5424 else
5425 cs%t_shelf(i,j) = cs%T_shelf_missing
5426 endif
5427! endif
5428
5429 if ((iss%hmask(i,j) == 1) .or. (iss%hmask(i,j) == 2)) then
5430 if (iss%h_shelf(i,j) > 0.0) then
5431 cs%t_shelf(i,j) = cs%t_shelf(i,j) + &
5432 time_step*(adot*tsurf - melt_rate(i,j)*iss%tfreeze(i,j))/(cs%density_ice*iss%h_shelf(i,j))
5433 else
5434 ! the ice is about to melt away in this case set thickness, area, and mask to zero
5435 ! NOTE: not mass conservative, should maybe scale salt & heat flux for this cell
5436 cs%t_shelf(i,j) = cs%T_shelf_missing
5437 cs%tmask(i,j) = 0.0
5438 endif
5439 elseif (iss%hmask(i,j) == 0) then
5440 cs%t_shelf(i,j) = cs%T_shelf_missing
5441 elseif ((iss%hmask(i,j) == 3) .or. (iss%hmask(i,j) == -2)) then
5442 cs%t_shelf(i,j) = cs%t_bdry_val(i,j)
5443 endif
5444 enddo ; enddo
5445
5446 call pass_var(cs%t_shelf, g%domain, complete=.false.)
5447 call pass_var(cs%tmask, g%domain, complete=.true.)
5448
5449 if (cs%debug) then
5450 call hchksum(cs%t_shelf, "temp after front", g%HI, haloshift=3, unscale=us%C_to_degC)
5451 endif
5452
5453end subroutine ice_shelf_temp
5454
5455
5456subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux)
5457 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
5458 type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf.
5459 real, intent(in) :: time_step !< The time step for this update [T ~> s].
5460 real, dimension(SZDI_(G),SZDJ_(G)), &
5461 intent(in) :: hmask !< A mask indicating which tracer points are
5462 !! partly or fully covered by an ice-shelf
5463 real, dimension(SZDI_(G),SZDJ_(G)), &
5464 intent(in) :: h0 !< The initial ice shelf thicknesses times temperature [C Z ~> degC m]
5465 real, dimension(SZDI_(G),SZDJ_(G)), &
5466 intent(inout) :: h_after_uflux !< The ice shelf thicknesses times temperature after
5467 !! the zonal mass fluxes [C Z ~> degC m]
5468
5469 ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells
5470 ! if there is an input bdry condition, the thickness there will be set in initialization
5471
5472 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed
5473 integer :: i_off, j_off
5474 logical :: at_east_bdry, at_west_bdry
5475 real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m]
5476 real :: u_face ! Zonal velocity at a face, positive if out [L T-1 ~> m s-1]
5477 real :: flux_diff ! The difference in fluxes [C Z ~> degC m]
5478 real :: phi ! A limiting ratio [nondim]
5479
5480 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
5481 i_off = g%idg_offset ; j_off = g%jdg_offset
5482
5483 do j=jsd+1,jed-1
5484 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
5485 ((j+j_off) >= g%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries
5486
5487 stencil(:) = 0.0 ! This is probably unnecessary, as the code is written
5488! if (i+i_off == G%domain%nihalo+G%domain%nihalo)
5489 do i=is,ie
5490
5491 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
5492 ((i+i_off) >= g%domain%nihalo+1)) then
5493
5494 if (i+i_off == g%domain%nihalo+1) then
5495 at_west_bdry=.true.
5496 else
5497 at_west_bdry=.false.
5498 endif
5499
5500 if (i+i_off == g%domain%niglobal+g%domain%nihalo) then
5501 at_east_bdry=.true.
5502 else
5503 at_east_bdry=.false.
5504 endif
5505
5506 if (hmask(i,j) == 1) then
5507
5508 h_after_uflux(i,j) = h0(i,j)
5509
5510 stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2
5511
5512 flux_diff = 0
5513
5514 ! 1ST DO LEFT FACE
5515
5516 if (cs%u_face_mask(i-1,j) == 4.) then
5517
5518 flux_diff = flux_diff + g%dyCu(i-1,j) * time_step * cs%u_flux_bdry_val(i-1,j) * &
5519 cs%t_bdry_val(i-1,j) / g%areaT(i,j)
5520 else
5521
5522 ! get u-velocity at center of left face
5523 u_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i-1,j))
5524
5525 if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available
5526
5527 ! i may not cover all the cases.. but i cover the realistic ones
5528
5529 if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a
5530 ! thickness bdry condition, and the stencil contains it
5531 flux_diff = flux_diff + abs(u_face) * g%dyCu(i-1,j) * time_step * stencil(-1) / g%areaT(i,j)
5532
5533 elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid
5534 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
5535 flux_diff = flux_diff + ((abs(u_face) * g%dyCu(i-1,j)* time_step / g%areaT(i,j)) * &
5536 (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2)))
5537
5538 else ! h(i-1) is valid
5539 ! (o.w. flux would most likely be out of cell)
5540 ! but h(i-2) is not
5541
5542 flux_diff = flux_diff + abs(u_face) * g%dyCu(i-1,j) * time_step / g%areaT(i,j) * stencil(-1)
5543
5544 endif
5545
5546 elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available
5547 if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid
5548 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
5549 flux_diff = flux_diff - ((abs(u_face) * g%dyCu(i-1,j) * time_step / g%areaT(i,j)) * &
5550 (stencil(0) - (phi * (stencil(0)-stencil(-1))/2)))
5551
5552 else
5553 flux_diff = flux_diff - abs(u_face) * g%dyCu(i-1,j) * time_step / g%areaT(i,j) * stencil(0)
5554 endif
5555 endif
5556 endif
5557
5558 ! NEXT DO RIGHT FACE
5559
5560 ! get u-velocity at center of eastern face
5561
5562 if (cs%u_face_mask(i,j) == 4.) then
5563
5564 flux_diff = flux_diff + g%dyCu(i,j) * time_step * cs%u_flux_bdry_val(i,j) *&
5565 cs%t_bdry_val(i+1,j) / g%areaT(i,j)
5566 else
5567
5568 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
5569
5570 if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available
5571
5572 if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a
5573 ! thickness bdry condition, and the stencil contains it
5574
5575 flux_diff = flux_diff + abs(u_face) * g%dyCu(i,j) * time_step * stencil(1) / g%areaT(i,j)
5576
5577 elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid
5578
5579 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
5580 flux_diff = flux_diff + ((abs(u_face) * g%dyCu(i,j) * time_step / g%areaT(i,j)) * &
5581 (stencil(1) - (phi * (stencil(1)-stencil(0))/2)))
5582
5583 else ! h(i+1) is valid
5584 ! (o.w. flux would most likely be out of cell)
5585 ! but h(i+2) is not
5586
5587 flux_diff = flux_diff + abs(u_face) * g%dyCu(i,j) * time_step / g%areaT(i,j) * stencil(1)
5588
5589 endif
5590
5591 elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available
5592
5593 if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid
5594
5595 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
5596 flux_diff = flux_diff - ((abs(u_face) * g%dyCu(i,j) * time_step / g%areaT(i,j)) * &
5597 (stencil(0) - (phi * (stencil(0)-stencil(1))/2)))
5598
5599 else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not
5600
5601 flux_diff = flux_diff - abs(u_face) * g%dyCu(i,j) * time_step / g%areaT(i,j) * stencil(0)
5602
5603 endif
5604
5605 endif
5606
5607 h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff
5608
5609 endif
5610
5611 endif
5612
5613 endif
5614
5615 enddo ! i loop
5616
5617 endif
5618
5619 enddo ! j loop
5620
5621end subroutine ice_shelf_advect_temp_x
5622
5623subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux)
5624 type(ice_shelf_dyn_cs), intent(in) :: CS !< A pointer to the ice shelf control structure
5625 type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
5626 real, intent(in) :: time_step !< The time step for this update [T ~> s].
5627 real, dimension(SZDI_(G),SZDJ_(G)), &
5628 intent(in) :: hmask !< A mask indicating which tracer points are
5629 !! partly or fully covered by an ice-shelf
5630 real, dimension(SZDI_(G),SZDJ_(G)), &
5631 intent(in) :: h_after_uflux !< The ice shelf thicknesses times temperature after
5632 !! the zonal mass fluxes [C Z ~> degC m].
5633 real, dimension(SZDI_(G),SZDJ_(G)), &
5634 intent(inout) :: h_after_vflux !< The ice shelf thicknesses times temperature after
5635 !! the meridional mass fluxes [C Z ~> degC m]
5636
5637 ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells
5638 ! if there is an input bdry condition, the thickness there will be set in initialization
5639
5640 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed
5641 integer :: i_off, j_off
5642 logical :: at_north_bdry, at_south_bdry
5643 real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m]
5644 real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out [L T-1 ~> m s-1]
5645 real :: flux_diff ! The difference in fluxes [C Z ~> degC m]
5646 real :: phi
5647
5648 is = g%isc ; ie = g%iec ; js = g%jsc-1 ; je = g%jec+1 ; isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
5649 i_off = g%idg_offset ; j_off = g%jdg_offset
5650
5651 do i=isd+2,ied-2
5652 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
5653 ((i+i_off) >= g%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries
5654
5655 stencil(:) = 0.0 ! This is probably unnecessary, as the code is written
5656
5657 do j=js,je
5658
5659 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
5660 ((j+j_off) >= g%domain%njhalo+1)) then
5661
5662 if (j+j_off == g%domain%njhalo+1) then
5663 at_south_bdry=.true.
5664 else
5665 at_south_bdry=.false.
5666 endif
5667 if (j+j_off == g%domain%njglobal+g%domain%njhalo) then
5668 at_north_bdry=.true.
5669 else
5670 at_north_bdry=.false.
5671 endif
5672
5673 if (hmask(i,j) == 1) then
5674 h_after_vflux(i,j) = h_after_uflux(i,j)
5675
5676 stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2
5677 flux_diff = 0
5678
5679 ! 1ST DO south FACE
5680
5681 if (cs%v_face_mask(i,j-1) == 4.) then
5682
5683 flux_diff = flux_diff + g%dxCv(i,j-1) * time_step * cs%v_flux_bdry_val(i,j-1) * &
5684 cs%t_bdry_val(i,j-1)/ g%areaT(i,j)
5685 else
5686
5687 ! get u-velocity at center of west face
5688 v_face = 0.5 * (cs%v_shelf(i-1,j-1) + cs%v_shelf(i,j-1))
5689
5690 if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available
5691
5692 ! i may not cover all the cases.. but i cover the realistic ones
5693
5694 if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a
5695 ! thickness bdry condition, and the stencil contains it
5696 flux_diff = flux_diff + abs(v_face) * g%dxCv(i,j-1) * time_step * stencil(-1) / g%areaT(i,j)
5697
5698 elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid
5699
5700 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
5701 flux_diff = flux_diff + ((abs(v_face) * g%dxCv(i,j-1) * time_step / g%areaT(i,j)) * &
5702 (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2)))
5703
5704 else ! h(j-1) is valid
5705 ! (o.w. flux would most likely be out of cell)
5706 ! but h(j-2) is not
5707 flux_diff = flux_diff + abs(v_face) * g%dxCv(i,j-1) * time_step / g%areaT(i,j) * stencil(-1)
5708 endif
5709
5710 elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available
5711
5712 if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid
5713 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
5714 flux_diff = flux_diff - ((abs(v_face) * g%dxCv(i,j-1) * time_step / g%areaT(i,j)) * &
5715 (stencil(0) - (phi * (stencil(0)-stencil(-1))/2)))
5716 else
5717 flux_diff = flux_diff - abs(v_face) * g%dxCv(i,j-1) * time_step / g%areaT(i,j) * stencil(0)
5718 endif
5719
5720 endif
5721
5722 endif
5723
5724 ! NEXT DO north FACE
5725
5726 if (cs%v_face_mask(i,j) == 4.) then
5727 flux_diff = flux_diff + g%dxCv(i,j) * time_step * cs%v_flux_bdry_val(i,j) *&
5728 cs%t_bdry_val(i,j+1)/ g%areaT(i,j)
5729 else
5730
5731 ! get u-velocity at center of east face
5732 v_face = 0.5 * (cs%v_shelf(i-1,j) + cs%v_shelf(i,j))
5733
5734 if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available
5735
5736 if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a
5737 ! thickness bdry condition, and the stencil contains it
5738 flux_diff = flux_diff + abs(v_face) * g%dxCv(i,j) * time_step * stencil(1) / g%areaT(i,j)
5739 elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid
5740 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
5741 flux_diff = flux_diff + ((abs(v_face) * g%dxCv(i,j) * time_step / g%areaT(i,j)) * &
5742 (stencil(1) - (phi * (stencil(1)-stencil(0))/2)))
5743 else ! h(j+1) is valid
5744 ! (o.w. flux would most likely be out of cell)
5745 ! but h(j+2) is not
5746 flux_diff = flux_diff + abs(v_face) * g%dxCv(i,j) * time_step / g%areaT(i,j) * stencil(1)
5747 endif
5748
5749 elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available
5750
5751 if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid
5752 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
5753 flux_diff = flux_diff - ((abs(v_face) * g%dxCv(i,j) * time_step / g%areaT(i,j)) * &
5754 (stencil(0) - (phi * (stencil(0)-stencil(1))/2)))
5755 else ! h(j+1) is valid
5756 ! (o.w. flux would most likely be out of cell)
5757 ! but h(j+2) is not
5758 flux_diff = flux_diff - abs(v_face) * g%dxCv(i,j) * time_step / g%areaT(i,j) * stencil(0)
5759 endif
5760
5761 endif
5762
5763 endif
5764
5765 h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff
5766 endif
5767 endif
5768 enddo ! j loop
5769 endif
5770 enddo ! i loop
5771
5772end subroutine ice_shelf_advect_temp_y
5773
5774end module mom_ice_shelf_dynamics