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