7 use mom_cpu_clock,
only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
27 implicit none ;
private
29 #include <MOM_memory.h>
31 public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf
32 public ice_time_step_cfl, ice_shelf_dyn_end
33 public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask
42 real,
pointer,
dimension(:,:) :: u_shelf => null()
44 real,
pointer,
dimension(:,:) :: v_shelf => null()
47 real,
pointer,
dimension(:,:) :: u_face_mask => null()
55 real,
pointer,
dimension(:,:) :: v_face_mask => null()
57 real,
pointer,
dimension(:,:) :: u_face_mask_bdry => null()
58 real,
pointer,
dimension(:,:) :: v_face_mask_bdry => null()
59 real,
pointer,
dimension(:,:) :: u_flux_bdry_val => null()
61 real,
pointer,
dimension(:,:) :: v_flux_bdry_val => null()
64 real,
pointer,
dimension(:,:) :: umask => null()
67 real,
pointer,
dimension(:,:) :: vmask => null()
70 real,
pointer,
dimension(:,:) :: calve_mask => null()
72 real,
pointer,
dimension(:,:) :: t_shelf => null()
74 real,
pointer,
dimension(:,:) :: tmask => null()
75 real,
pointer,
dimension(:,:) :: ice_visc => null()
76 real,
pointer,
dimension(:,:) :: thickness_bdry_val => null()
77 real,
pointer,
dimension(:,:) :: u_bdry_val => null()
78 real,
pointer,
dimension(:,:) :: v_bdry_val => null()
79 real,
pointer,
dimension(:,:) :: h_bdry_val => null()
80 real,
pointer,
dimension(:,:) :: t_bdry_val => null()
82 real,
pointer,
dimension(:,:) :: taub_beta_eff => null()
85 real,
pointer,
dimension(:,:) :: od_rt => null()
86 real,
pointer,
dimension(:,:) :: float_frac_rt => null()
87 real,
pointer,
dimension(:,:) :: od_av => null()
88 real,
pointer,
dimension(:,:) :: float_frac => null()
91 integer :: od_rt_counter = 0
93 real :: velocity_update_time_step
99 real :: elapsed_velocity_time
104 logical :: gl_regularize
106 integer :: n_sub_regularize
119 real :: a_glen_isothermal
122 real :: c_basal_friction
124 real :: n_basal_friction
125 real :: density_ocean_avg
129 real :: thresh_float_col_depth
130 logical :: moving_shelf_front
131 logical :: calve_to_mask
132 real :: min_thickness_simple_calve
136 real :: nonlinear_tolerance
138 integer :: cg_max_iterations
139 integer :: nonlin_solve_err_mode
141 logical :: use_reproducing_sums
148 logical :: module_is_initialized = .false.
151 integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, &
152 id_float_frac = -1, id_col_thick = -1, id_od_av = -1, &
153 id_u_mask = -1, id_v_mask = -1, id_t_mask = -1
165 function slope_limiter(num, denom)
166 real,
intent(in) :: num
167 real,
intent(in) :: denom
168 real :: slope_limiter
173 elseif (num*denom <= 0)
then
177 slope_limiter = (r+abs(r))/(1+abs(r))
180 end function slope_limiter
183 function quad_area (X, Y)
184 real,
dimension(4),
intent(in) :: x
185 real,
dimension(4),
intent(in) :: y
186 real :: quad_area, p2, q2, a2, c2, b2, d2
193 p2 = (x(4)-x(1))**2 + (y(4)-y(1))**2 ; q2 = (x(3)-x(2))**2 + (y(3)-y(2))**2
194 a2 = (x(3)-x(4))**2 + (y(3)-y(4))**2 ; c2 = (x(1)-x(2))**2 + (y(1)-y(2))**2
195 b2 = (x(2)-x(4))**2 + (y(2)-y(4))**2 ; d2 = (x(3)-x(1))**2 + (y(3)-y(1))**2
196 quad_area = .25 * sqrt(4*p2*q2-(b2+d2-a2-c2)**2)
198 end function quad_area
202 subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS)
208 logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics
209 character(len=40) :: mdl =
"MOM_ice_shelf_dyn"
210 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
212 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
213 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
215 if (
associated(cs))
then
216 call mom_error(fatal,
"MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// &
217 "called with an associated control structure.")
222 override_shelf_movement = .false. ; active_shelf_dynamics = .false.
223 call get_param(param_file, mdl,
"DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, &
224 "If true, the ice sheet mass can evolve with time.", &
225 default=.false., do_not_log=.true.)
226 if (shelf_mass_is_dynamic)
then
227 call get_param(param_file, mdl,
"OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, &
228 "If true, user provided code specifies the ice-shelf "//&
229 "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.)
230 active_shelf_dynamics = .not.override_shelf_movement
233 if (active_shelf_dynamics)
then
234 allocate( cs%u_shelf(isdb:iedb,jsdb:jedb) ) ; cs%u_shelf(:,:) = 0.0
235 allocate( cs%v_shelf(isdb:iedb,jsdb:jedb) ) ; cs%v_shelf(:,:) = 0.0
236 allocate( cs%t_shelf(isd:ied,jsd:jed) ) ; cs%t_shelf(:,:) = -10.0
237 allocate( cs%ice_visc(isd:ied,jsd:jed) ) ; cs%ice_visc(:,:) = 0.0
238 allocate( cs%taub_beta_eff(isd:ied,jsd:jed) ) ; cs%taub_beta_eff(:,:) = 0.0
239 allocate( cs%OD_av(isd:ied,jsd:jed) ) ; cs%OD_av(:,:) = 0.0
240 allocate( cs%float_frac(isd:ied,jsd:jed) ) ; cs%float_frac(:,:) = 0.0
244 "ice sheet/shelf u-velocity",
"m s-1", hor_grid=
'Bu')
246 "ice sheet/shelf v-velocity",
"m s-1", hor_grid=
'Bu')
248 "ice sheet/shelf vertically averaged temperature",
"deg C")
250 "Average open ocean depth in a cell",
"m")
252 "fractional degree of grounding",
"nondim")
254 "Glens law ice viscosity",
"m (seems wrong)")
256 "Coefficient of basal traction",
"m (seems wrong)")
259 end subroutine register_ice_shelf_dyn_restarts
262 subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in)
265 type(time_type),
intent(inout) :: time
271 type(
diag_ctrl),
target,
intent(in) :: diag
272 logical,
intent(in) :: new_sim
274 logical,
optional,
intent(in) :: solo_ice_sheet_in
281 # include "version_variable.h"
282 character(len=200) :: config
283 character(len=200) :: ic_file,filename,inputdir
284 character(len=40) :: var_name
285 character(len=40) :: mdl =
"MOM_ice_shelf_dyn"
286 logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics
288 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, isdq, iedq, jsdq, jedq, iters
290 if (.not.
associated(cs))
then
291 call mom_error(fatal,
"MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// &
292 "called with an associated control structure.")
295 if (cs%module_is_initialized)
then
296 call mom_error(warning,
"MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//&
297 "called with a control structure that has already been initialized.")
299 cs%module_is_initialized = .true.
305 call get_param(param_file, mdl,
"DEBUG", debug, default=.false.)
306 call get_param(param_file, mdl,
"DEBUG_IS", cs%debug, &
307 "If true, write verbose debugging messages for the ice shelf.", &
309 call get_param(param_file, mdl,
"DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, &
310 "If true, the ice sheet mass can evolve with time.", &
312 override_shelf_movement = .false. ; active_shelf_dynamics = .false.
313 if (shelf_mass_is_dynamic)
then
314 call get_param(param_file, mdl,
"OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, &
315 "If true, user provided code specifies the ice-shelf "//&
316 "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.)
317 active_shelf_dynamics = .not.override_shelf_movement
319 call get_param(param_file, mdl,
"GROUNDING_LINE_INTERPOLATE", cs%GL_regularize, &
320 "If true, regularize the floatation condition at the "//&
321 "grounding line as in Goldberg Holland Schoof 2009.", default=.false.)
322 call get_param(param_file, mdl,
"GROUNDING_LINE_INTERP_SUBGRID_N", cs%n_sub_regularize, &
323 "The number of sub-partitions of each cell over which to "//&
324 "integrate for the interpolated grounding line. Each cell "//&
325 "is divided into NxN equally-sized rectangles, over which the "//&
326 "basal contribution is integrated by iterative quadrature.", &
328 call get_param(param_file, mdl,
"GROUNDING_LINE_COUPLE", cs%GL_couple, &
329 "If true, let the floatation condition be determined by "//&
330 "ocean column thickness. This means that update_OD_ffrac "//&
331 "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", &
332 default=.false., do_not_log=cs%GL_regularize)
333 if (cs%GL_regularize) cs%GL_couple = .false.
334 if (cs%GL_regularize .and. (cs%n_sub_regularize == 0))
call mom_error (fatal, &
335 "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used")
336 call get_param(param_file, mdl,
"ICE_SHELF_CFL_FACTOR", cs%CFL_factor, &
337 "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//&
338 "This is only used with an ice-only model.", default=0.25)
340 call get_param(param_file, mdl,
"RHO_0", cs%density_ocean_avg, &
341 "avg ocean density used in floatation cond", &
342 units=
"kg m-3", default=1035.)
343 if (active_shelf_dynamics)
then
344 call get_param(param_file, mdl,
"ICE_VELOCITY_TIMESTEP", cs%velocity_update_time_step, &
345 "seconds between ice velocity calcs", units=
"s", &
346 fail_if_missing=.true.)
347 call get_param(param_file, mdl,
"G_EARTH", cs%g_Earth, &
348 "The gravitational acceleration of the Earth.", &
349 units=
"m s-2", default = 9.80)
351 call get_param(param_file, mdl,
"A_GLEN_ISOTHERM", cs%A_glen_isothermal, &
352 "Ice viscosity parameter in Glen's Law", &
353 units=
"Pa -1/3 a", default=9.461e-18)
354 call get_param(param_file, mdl,
"GLEN_EXPONENT", cs%n_glen, &
355 "nonlinearity exponent in Glen's Law", &
356 units=
"none", default=3.)
357 call get_param(param_file, mdl,
"MIN_STRAIN_RATE_GLEN", cs%eps_glen_min, &
358 "min. strain rate to avoid infinite Glen's law viscosity", &
359 units=
"a-1", default=1.e-12)
360 call get_param(param_file, mdl,
"BASAL_FRICTION_COEFF", cs%C_basal_friction, &
361 "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", &
362 units=
"Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.)
363 call get_param(param_file, mdl,
"BASAL_FRICTION_EXP", cs%n_basal_friction, &
364 "exponent in sliding law \tau_b = C u^(m_slide)", &
365 units=
"none", fail_if_missing=.true.)
366 call get_param(param_file, mdl,
"DENSITY_ICE", cs%density_ice, &
367 "A typical density of ice.", units=
"kg m-3", default=917.0)
368 call get_param(param_file, mdl,
"CONJUGATE_GRADIENT_TOLERANCE", cs%cg_tolerance, &
369 "tolerance in CG solver, relative to initial residual", default=1.e-6)
370 call get_param(param_file, mdl,
"ICE_NONLINEAR_TOLERANCE", cs%nonlinear_tolerance, &
371 "nonlin tolerance in iterative velocity solve",default=1.e-6)
372 call get_param(param_file, mdl,
"CONJUGATE_GRADIENT_MAXIT", cs%cg_max_iterations, &
373 "max iteratiions in CG solver", default=2000)
374 call get_param(param_file, mdl,
"THRESH_FLOAT_COL_DEPTH", cs%thresh_float_col_depth, &
375 "min ocean thickness to consider ice *floating*; "//&
376 "will only be important with use of tides", &
377 units=
"m", default=1.e-3, scale=us%m_to_Z)
378 call get_param(param_file, mdl,
"NONLIN_SOLVE_ERR_MODE", cs%nonlin_solve_err_mode, &
379 "Choose whether nonlin error in vel solve is based on nonlinear "//&
380 "residual (1) or relative change since last iteration (2)", default=1)
381 call get_param(param_file, mdl,
"SHELF_DYN_REPRODUCING_SUMS", cs%use_reproducing_sums, &
382 "If true, use the reproducing extended-fixed-point sums in "//&
383 "the ice shelf dynamics solvers.", default=.true.)
385 call get_param(param_file, mdl,
"SHELF_MOVING_FRONT", cs%moving_shelf_front, &
386 "Specify whether to advance shelf front (and calve).", &
388 call get_param(param_file, mdl,
"CALVE_TO_MASK", cs%calve_to_mask, &
389 "If true, do not allow an ice shelf where prohibited by a mask.", &
392 call get_param(param_file, mdl,
"MIN_THICKNESS_SIMPLE_CALVE", &
393 cs%min_thickness_simple_calve, &
394 "Min thickness rule for the VERY simple calving law",&
395 units=
"m", default=0.0, scale=us%m_to_Z)
401 if (active_shelf_dynamics)
then
403 allocate( cs%u_bdry_val(isdq:iedq,jsdq:jedq) ) ; cs%u_bdry_val(:,:) = 0.0
404 allocate( cs%v_bdry_val(isdq:iedq,jsdq:jedq) ) ; cs%v_bdry_val(:,:) = 0.0
405 allocate( cs%t_bdry_val(isd:ied,jsd:jed) ) ; cs%t_bdry_val(:,:) = -15.0
406 allocate( cs%h_bdry_val(isd:ied,jsd:jed) ) ; cs%h_bdry_val(:,:) = 0.0
407 allocate( cs%thickness_bdry_val(isd:ied,jsd:jed) ) ; cs%thickness_bdry_val(:,:) = 0.0
408 allocate( cs%u_face_mask(isdq:iedq,jsd:jed) ) ; cs%u_face_mask(:,:) = 0.0
409 allocate( cs%v_face_mask(isd:ied,jsdq:jedq) ) ; cs%v_face_mask(:,:) = 0.0
410 allocate( cs%u_face_mask_bdry(isdq:iedq,jsd:jed) ) ; cs%u_face_mask_bdry(:,:) = -2.0
411 allocate( cs%v_face_mask_bdry(isd:ied,jsdq:jedq) ) ; cs%v_face_mask_bdry(:,:) = -2.0
412 allocate( cs%u_flux_bdry_val(isdq:iedq,jsd:jed) ) ; cs%u_flux_bdry_val(:,:) = 0.0
413 allocate( cs%v_flux_bdry_val(isd:ied,jsdq:jedq) ) ; cs%v_flux_bdry_val(:,:) = 0.0
414 allocate( cs%umask(isdq:iedq,jsdq:jedq) ) ; cs%umask(:,:) = -1.0
415 allocate( cs%vmask(isdq:iedq,jsdq:jedq) ) ; cs%vmask(:,:) = -1.0
416 allocate( cs%tmask(isdq:iedq,jsdq:jedq) ) ; cs%tmask(:,:) = -1.0
419 allocate( cs%OD_rt(isd:ied,jsd:jed) ) ; cs%OD_rt(:,:) = 0.0
420 allocate( cs%float_frac_rt(isd:ied,jsd:jed) ) ; cs%float_frac_rt(:,:) = 0.0
422 if (cs%calve_to_mask)
then
423 allocate( cs%calve_mask(isd:ied,jsd:jed) ) ; cs%calve_mask(:,:) = 0.0
426 cs%elapsed_velocity_time = 0.0
428 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
432 if (active_shelf_dynamics .and. .not.new_sim)
then
433 if ((us%m_to_Z_restart /= 0.0) .and. (us%m_to_Z_restart /= us%m_to_Z))
then
434 z_rescale = us%m_to_Z / us%m_to_Z_restart
435 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
436 cs%OD_av(i,j) = z_rescale * cs%OD_av(i,j)
445 if (.not. g%symmetric)
then
446 do j=g%jsd,g%jed ;
do i=g%isd,g%ied
447 if (((i+g%idg_offset) == (g%domain%nihalo+1)).and.(cs%u_face_mask(i-1,j) == 3))
then
448 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
449 cs%u_shelf(i-1,j) = cs%u_bdry_val(i-1,j)
451 if (((j+g%jdg_offset) == (g%domain%njhalo+1)).and.(cs%v_face_mask(i,j-1) == 3))
then
452 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
453 cs%u_shelf(i,j-1) = cs%u_bdry_val(i,j-1)
459 call pass_var(cs%float_frac,g%domain)
461 call pass_var(cs%taub_beta_eff,g%domain)
462 call pass_vector(cs%u_shelf, cs%v_shelf, g%domain, to_all, bgrid_ne)
465 if (active_shelf_dynamics)
then
467 if (cs%calve_to_mask)
then
468 call mom_mesg(
" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask")
470 call get_param(param_file, mdl,
"INPUTDIR", inputdir, default=
".")
471 inputdir = slasher(inputdir)
472 call get_param(param_file, mdl,
"CALVING_MASK_FILE", ic_file, &
473 "The file with a mask for where calving might occur.", &
474 default=
"ice_shelf_h.nc")
475 call get_param(param_file, mdl,
"CALVING_MASK_VARNAME", var_name, &
476 "The variable to use in masking calving.", &
477 default=
"area_shelf_h")
479 filename = trim(inputdir)//trim(ic_file)
480 call log_param(param_file, mdl,
"INPUTDIR/CALVING_MASK_FILE", filename)
481 if (.not.
file_exists(filename, g%Domain))
call mom_error(fatal, &
482 " calving mask file: Unable to open "//trim(filename))
484 call mom_read_data(filename,trim(var_name),cs%calve_mask,g%Domain)
485 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
486 if (cs%calve_mask(i,j) > 0.0) cs%calve_mask(i,j) = 1.0
488 call pass_var(cs%calve_mask,g%domain)
494 call mom_mesg(
"MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.")
495 call update_od_ffrac_uncoupled(cs, g, iss%h_shelf(:,:))
496 call ice_shelf_solve_outer(cs, iss, g, us, cs%u_shelf, cs%v_shelf, iters, time)
498 if (cs%id_u_shelf > 0)
call post_data(cs%id_u_shelf,cs%u_shelf,cs%diag)
499 if (cs%id_v_shelf > 0)
call post_data(cs%id_v_shelf,cs%v_shelf,cs%diag)
503 cs%id_u_shelf = register_diag_field(
'ocean_model',
'u_shelf',cs%diag%axesCu1, time, &
504 'x-velocity of ice',
'm yr-1')
505 cs%id_v_shelf = register_diag_field(
'ocean_model',
'v_shelf',cs%diag%axesCv1, time, &
506 'y-velocity of ice',
'm yr-1')
507 cs%id_u_mask = register_diag_field(
'ocean_model',
'u_mask',cs%diag%axesCu1, time, &
508 'mask for u-nodes',
'none')
509 cs%id_v_mask = register_diag_field(
'ocean_model',
'v_mask',cs%diag%axesCv1, time, &
510 'mask for v-nodes',
'none')
513 cs%id_float_frac = register_diag_field(
'ocean_model',
'ice_float_frac',cs%diag%axesT1, time, &
514 'fraction of cell that is floating (sort of)',
'none')
515 cs%id_col_thick = register_diag_field(
'ocean_model',
'col_thick',cs%diag%axesT1, time, &
516 'ocean column thickness passed to ice model',
'm', conversion=us%Z_to_m)
517 cs%id_OD_av = register_diag_field(
'ocean_model',
'OD_av',cs%diag%axesT1, time, &
518 'intermediate ocean column thickness passed to ice model',
'm', conversion=us%Z_to_m)
527 cs%id_t_shelf = register_diag_field(
'ocean_model',
't_shelf',cs%diag%axesT1, time, &
529 cs%id_t_mask = register_diag_field(
'ocean_model',
'tmask',cs%diag%axesT1, time, &
530 'mask for T-nodes',
'none')
533 end subroutine initialize_ice_shelf_dyn
536 subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time)
542 type(time_type),
intent(in) :: Time
544 integer :: i, j, iters, isd, ied, jsd, jed
545 real :: rhoi_rhow, OD
546 type(time_type) :: dummy_time
548 rhoi_rhow = cs%density_ice / cs%density_ocean_avg
549 dummy_time = set_time(0,0)
550 isd=g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
554 od = g%bathyT(i,j) - rhoi_rhow * iss%h_shelf(i,j)
558 cs%float_frac(i,j) = 0.
561 cs%float_frac(i,j) = 1.
566 call ice_shelf_solve_outer(cs, iss, g, us, cs%u_shelf, cs%v_shelf, iters, dummy_time)
568 end subroutine initialize_diagnostic_fields
572 function ice_time_step_cfl(CS, ISS, G)
577 real :: ice_time_step_cfl
579 real :: ratio, min_ratio
580 real :: local_u_max, local_v_max
584 do j=g%jsc,g%jec ;
do i=g%isc,g%iec ;
if (iss%hmask(i,j) == 1.0)
then
585 local_u_max = max(abs(cs%u_shelf(i,j)), abs(cs%u_shelf(i+1,j+1)), &
586 abs(cs%u_shelf(i+1,j)), abs(cs%u_shelf(i,j+1)))
587 local_v_max = max(abs(cs%v_shelf(i,j)), abs(cs%v_shelf(i+1,j+1)), &
588 abs(cs%v_shelf(i+1,j)), abs(cs%v_shelf(i,j+1)))
590 ratio = min(g%areaT(i,j) / (local_u_max+1.0e-12), g%areaT(i,j) / (local_v_max+1.0e-12))
591 min_ratio = min(min_ratio, ratio)
592 endif ;
enddo ;
enddo
594 call min_across_pes(min_ratio)
597 ice_time_step_cfl = cs%CFL_factor * min_ratio * (365*86400)
599 end function ice_time_step_cfl
603 subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel)
609 real,
intent(in) :: time_step
610 type(time_type),
intent(in) :: time
611 real,
dimension(SZDI_(G),SZDJ_(G)), &
612 optional,
intent(in) :: ocean_mass
614 logical,
optional,
intent(in) :: coupled_grounding
616 logical,
optional,
intent(in) :: must_update_vel
619 logical :: update_ice_vel, coupled_gl
621 update_ice_vel = .false.
622 if (
present(must_update_vel)) update_ice_vel = must_update_vel
625 if (
present(ocean_mass) .and.
present(coupled_grounding)) coupled_gl = coupled_grounding
627 call ice_shelf_advect(cs, iss, g, time_step, time)
628 cs%elapsed_velocity_time = cs%elapsed_velocity_time + time_step
629 if (cs%elapsed_velocity_time >= cs%velocity_update_time_step) update_ice_vel = .true.
632 call update_od_ffrac(cs, g, us, ocean_mass, update_ice_vel)
633 elseif (update_ice_vel)
then
634 call update_od_ffrac_uncoupled(cs, g, iss%h_shelf(:,:))
637 if (update_ice_vel)
then
638 call ice_shelf_solve_outer(cs, iss, g, us, cs%u_shelf, cs%v_shelf, iters, time)
641 call ice_shelf_temp(cs, iss, g, us, time_step, iss%water_flux, time)
643 if (update_ice_vel)
then
644 call enable_averaging(cs%elapsed_velocity_time, time, cs%diag)
645 if (cs%id_col_thick > 0)
call post_data(cs%id_col_thick, cs%OD_av, cs%diag)
646 if (cs%id_u_shelf > 0)
call post_data(cs%id_u_shelf,cs%u_shelf,cs%diag)
647 if (cs%id_v_shelf > 0)
call post_data(cs%id_v_shelf,cs%v_shelf,cs%diag)
648 if (cs%id_t_shelf > 0)
call post_data(cs%id_t_shelf,cs%t_shelf,cs%diag)
649 if (cs%id_float_frac > 0)
call post_data(cs%id_float_frac,cs%float_frac,cs%diag)
650 if (cs%id_OD_av >0)
call post_data(cs%id_OD_av, cs%OD_av,cs%diag)
652 if (cs%id_u_mask > 0)
call post_data(cs%id_u_mask,cs%umask,cs%diag)
653 if (cs%id_v_mask > 0)
call post_data(cs%id_v_mask,cs%vmask,cs%diag)
654 if (cs%id_t_mask > 0)
call post_data(cs%id_t_mask,cs%tmask,cs%diag)
656 call disable_averaging(cs%diag)
658 cs%elapsed_velocity_time = 0.0
661 end subroutine update_ice_shelf
666 subroutine ice_shelf_advect(CS, ISS, G, time_step, Time)
671 real,
intent(in) :: time_step
672 type(time_type),
intent(in) :: Time
706 real,
dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux
707 real,
dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter
708 integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec
714 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
715 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
716 flux_enter(:,:,:) = 0.0
718 h_after_uflux(:,:) = 0.0
719 h_after_vflux(:,:) = 0.0
722 do j=jsd,jed ;
do i=isd,ied ;
if (cs%thickness_bdry_val(i,j) /= 0.0)
then
723 iss%h_shelf(i,j) = cs%thickness_bdry_val(i,j)
724 endif ;
enddo ;
enddo
726 call ice_shelf_advect_thickness_x(cs, g, time_step/spy, iss%hmask, iss%h_shelf, h_after_uflux, flux_enter)
733 call ice_shelf_advect_thickness_y(cs, g, time_step/spy, iss%hmask, h_after_uflux, h_after_vflux, flux_enter)
742 if (iss%hmask(i,j) == 1) iss%h_shelf(i,j) = h_after_vflux(i,j)
746 if (cs%moving_shelf_front)
then
747 call shelf_advance_front(cs, iss, g, flux_enter)
748 if (cs%min_thickness_simple_calve > 0.0)
then
749 call ice_shelf_min_thickness_calve(g, iss%h_shelf, iss%area_shelf_h, iss%hmask, &
750 cs%min_thickness_simple_calve)
752 if (cs%calve_to_mask)
then
753 call calve_to_mask(g, iss%h_shelf, iss%area_shelf_h, iss%hmask, cs%calve_mask)
763 call update_velocity_masks(cs, g, iss%hmask, cs%umask, cs%vmask, cs%u_face_mask, cs%v_face_mask)
765 end subroutine ice_shelf_advect
767 subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time)
773 real,
dimension(SZDIB_(G),SZDJB_(G)), &
775 real,
dimension(SZDIB_(G),SZDJB_(G)), &
777 integer,
intent(out) :: iters
778 type(time_type),
intent(in) :: Time
780 real,
dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, &
781 u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, &
783 real,
dimension(SZDIB_(G),SZDJB_(G)) :: H_node
784 real,
dimension(SZDI_(G),SZDJ_(G)) :: float_cond
786 character(len=160) :: mesg
787 integer :: conv_flag, i, j, k,l, iter
788 integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub
789 real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi_rhow
790 real,
pointer,
dimension(:,:,:,:) :: Phi => null()
791 real,
pointer,
dimension(:,:,:,:,:,:) :: Phisub => null()
792 real,
dimension(8,4) :: Phi_temp
793 real,
dimension(2,2) :: X,Y
794 character(2) :: iternum
795 character(2) :: numproc
798 nsub = cs%n_sub_regularize
800 isdq = g%isdB ; iedq = g%iedB ; jsdq = g%jsdB ; jedq = g%jedB
801 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
802 rhoi_rhow = cs%density_ice / cs%density_ocean_avg
804 taudx(:,:) = 0.0 ; taudy(:,:) = 0.0
805 u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0
806 au(:,:) = 0.0 ; av(:,:) = 0.0
809 float_cond(:,:) = 0.0 ; h_node(:,:)=0
810 allocate(phisub(nsub,nsub,2,2,2,2)) ; phisub = 0.0
814 if (g%isc+g%idg_offset==g%isg) isumstart = g%iscB
818 if (g%jsc+g%jdg_offset==g%jsg) jsumstart = g%jscB
820 call calc_shelf_driving_stress(cs, iss, g, us, taudx, taudy, cs%OD_av)
830 if (cs%GL_regularize)
then
832 call interpolate_h_to_b(g, iss%h_shelf, iss%hmask, h_node)
839 if ((iss%hmask(i,j) == 1) .and. &
840 (rhoi_rhow * h_node(i-1+k,j-1+l) - g%bathyT(i,j) <= 0))
then
841 nodefloat = nodefloat + 1
845 if ((nodefloat > 0) .and. (nodefloat < 4))
then
846 float_cond(i,j) = 1.0
847 cs%float_frac(i,j) = 1.0
854 call bilinear_shape_functions_subgrid(phisub, nsub)
860 u_prev_iterate(:,:) = u(:,:)
861 v_prev_iterate(:,:) = v(:,:)
864 allocate(phi(isd:ied,jsd:jed,1:8,1:4)) ; phi(:,:,:,:) = 0.0
866 do j=jsd,jed ;
do i=isd,ied
867 if (((i > isd) .and. (j > jsd)))
then
868 x(:,:) = g%geoLonBu(i-1:i,j-1:j)*1000
869 y(:,:) = g%geoLatBu(i-1:i,j-1:j)*1000
871 x(2,:) = g%geoLonBu(i,j)*1000
872 x(1,:) = g%geoLonBu(i,j)*1000-g%dxT(i,j)
873 y(:,2) = g%geoLatBu(i,j)*1000
874 y(:,1) = g%geoLatBu(i,j)*1000-g%dyT(i,j)
877 call bilinear_shape_functions(x, y, phi_temp, area)
878 phi(i,j,:,:) = phi_temp
881 call calc_shelf_visc(cs, iss, g, us, u, v)
883 call pass_var(cs%ice_visc, g%domain)
884 call pass_var(cs%taub_beta_eff, g%domain)
888 do j=g%jsd,g%jed ;
do i=g%isd,g%ied
889 cs%taub_beta_eff(i,j) = cs%taub_beta_eff(i,j) * cs%float_frac(i,j)
892 call apply_boundary_values(cs, iss, g, time, phisub, h_node, cs%ice_visc, &
893 cs%taub_beta_eff, float_cond, &
894 rhoi_rhow, u_bdry_cont, v_bdry_cont)
896 au(:,:) = 0.0 ; av(:,:) = 0.0
898 call cg_action(au, av, u, v, phi, phisub, cs%umask, cs%vmask, iss%hmask, h_node, &
899 cs%ice_visc, float_cond, g%bathyT(:,:), cs%taub_beta_eff, g%areaT, &
900 g, g%isc-1, g%iec+1, g%jsc-1, g%jec+1, rhoi_rhow)
902 err_init = 0 ; err_tempu = 0; err_tempv = 0
903 do j=jsumstart,g%jecB
904 do i=isumstart,g%iecB
905 if (cs%umask(i,j) == 1)
then
906 err_tempu = abs(au(i,j) + u_bdry_cont(i,j) - taudx(i,j))
908 if (cs%vmask(i,j) == 1)
then
909 err_tempv = max(abs(av(i,j) + v_bdry_cont(i,j) - taudy(i,j)), err_tempu)
911 if (err_tempv >= err_init)
then
917 call max_across_pes(err_init)
919 write(mesg,*)
"ice_shelf_solve_outer: INITIAL nonlinear residual = ",err_init
920 call mom_mesg(mesg, 5)
922 u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:)
928 call ice_shelf_solve_inner(cs, iss, g, u, v, taudx, taudy, h_node, float_cond, &
929 iss%hmask, conv_flag, iters, time, phi, phisub)
932 call qchksum(u,
"u shelf", g%HI, haloshift=2)
933 call qchksum(v,
"v shelf", g%HI, haloshift=2)
936 write(mesg,*)
"ice_shelf_solve_outer: linear solve done in ",iters,
" iterations"
937 call mom_mesg(mesg, 5)
939 call calc_shelf_visc(cs, iss, g, us, u, v)
940 call pass_var(cs%ice_visc, g%domain)
941 call pass_var(cs%taub_beta_eff, g%domain)
945 do j=g%jsd,g%jed ;
do i=g%isd,g%ied
946 cs%taub_beta_eff(i,j) = cs%taub_beta_eff(i,j) * cs%float_frac(i,j)
949 u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0
951 call apply_boundary_values(cs, iss, g, time, phisub, h_node, cs%ice_visc, &
952 cs%taub_beta_eff, float_cond, &
953 rhoi_rhow, u_bdry_cont, v_bdry_cont)
955 au(:,:) = 0 ; av(:,:) = 0
957 call cg_action(au, av, u, v, phi, phisub, cs%umask, cs%vmask, iss%hmask, h_node, &
958 cs%ice_visc, float_cond, g%bathyT(:,:), cs%taub_beta_eff, g%areaT, &
959 g, g%isc-1, g%iec+1, g%jsc-1, g%jec+1, rhoi_rhow)
963 if (cs%nonlin_solve_err_mode == 1)
then
965 do j=jsumstart,g%jecB
966 do i=isumstart,g%iecB
967 if (cs%umask(i,j) == 1)
then
968 err_tempu = abs(au(i,j) + u_bdry_cont(i,j) - taudx(i,j))
970 if (cs%vmask(i,j) == 1)
then
971 err_tempv = max(abs(av(i,j) + v_bdry_cont(i,j) - taudy(i,j)), err_tempu)
973 if (err_tempv >= err_max)
then
979 call max_across_pes(err_max)
981 elseif (cs%nonlin_solve_err_mode == 2)
then
983 max_vel = 0 ; tempu = 0 ; tempv = 0
985 do j=jsumstart,g%jecB
986 do i=isumstart,g%iecB
987 if (cs%umask(i,j) == 1)
then
988 err_tempu = abs(u_last(i,j)-u(i,j))
991 if (cs%vmask(i,j) == 1)
then
992 err_tempv = max(abs(v_last(i,j)- v(i,j)), err_tempu)
993 tempv = sqrt(v(i,j)**2+tempu**2)
995 if (err_tempv >= err_max)
then
998 if (tempv >= max_vel)
then
1004 u_last(:,:) = u(:,:)
1005 v_last(:,:) = v(:,:)
1007 call max_across_pes(max_vel)
1008 call max_across_pes(err_max)
1013 write(mesg,*)
"ice_shelf_solve_outer: nonlinear residual = ",err_max/err_init
1014 call mom_mesg(mesg, 5)
1016 if (err_max <= cs%nonlinear_tolerance * err_init)
then
1017 write(mesg,*)
"ice_shelf_solve_outer: exiting nonlinear solve after ",iter,
" iterations"
1018 call mom_mesg(mesg, 5)
1027 end subroutine ice_shelf_solve_outer
1029 subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, &
1030 hmask, conv_flag, iters, time, Phi, Phisub)
1035 real,
dimension(SZDIB_(G),SZDJB_(G)), &
1037 real,
dimension(SZDIB_(G),SZDJB_(G)), &
1039 real,
dimension(SZDIB_(G),SZDJB_(G)), &
1041 real,
dimension(SZDIB_(G),SZDJB_(G)), &
1043 real,
dimension(SZDIB_(G),SZDJB_(G)), &
1044 intent(in) :: H_node
1046 real,
dimension(SZDI_(G),SZDJ_(G)), &
1047 intent(in) :: float_cond
1049 real,
dimension(SZDI_(G),SZDJ_(G)), &
1052 integer,
intent(out) :: conv_flag
1054 integer,
intent(out) :: iters
1055 type(time_type),
intent(in) :: Time
1056 real,
dimension(SZDI_(G),SZDJ_(G),8,4), &
1059 real,
dimension(:,:,:,:,:,:), &
1060 intent(in) :: Phisub
1071 real,
dimension(SZDIB_(G),SZDJB_(G)) :: &
1072 Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, &
1073 ubd, vbd, Au, Av, Du, Dv, &
1074 Zu_old, Zv_old, Ru_old, Rv_old, &
1076 integer :: iter, i, j, isd, ied, jsd, jed, &
1077 isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, &
1078 isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo
1079 real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a
1080 character(2) :: gridsize
1082 real,
dimension(8,4) :: Phi_temp
1083 real,
dimension(2,2) :: X,Y
1085 isdq = g%isdB ; iedq = g%iedB ; jsdq = g%jsdB ; jedq = g%jedB
1086 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
1087 ny_halo = g%domain%njhalo ; nx_halo = g%domain%nihalo
1088 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
1089 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
1091 zu(:,:) = 0 ; zv(:,:) = 0 ; diagu(:,:) = 0 ; diagv(:,:) = 0
1092 ru(:,:) = 0 ; rv(:,:) = 0 ; au(:,:) = 0 ; av(:,:) = 0
1093 du(:,:) = 0 ; dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0
1094 dot_p1 = 0 ; dot_p2 = 0
1098 if (g%isc+g%idg_offset==g%isg) isumstart = g%iscB
1102 if (g%jsc+g%jdg_offset==g%jsg) jsumstart = g%jscB
1104 call apply_boundary_values(cs, iss, g, time, phisub, h_node, cs%ice_visc, &
1105 cs%taub_beta_eff, float_cond, &
1106 cs%density_ice/cs%density_ocean_avg, ubd, vbd)
1108 rhsu(:,:) = taudx(:,:) - ubd(:,:)
1109 rhsv(:,:) = taudy(:,:) - vbd(:,:)
1112 call pass_vector(rhsu, rhsv, g%domain, to_all, bgrid_ne)
1114 call matrix_diagonal(cs, g, float_cond, h_node, cs%ice_visc, &
1115 cs%taub_beta_eff, hmask, &
1116 cs%density_ice/cs%density_ocean_avg, phisub, diagu, diagv)
1119 call pass_vector(diagu, diagv, g%domain, to_all, bgrid_ne)
1121 call cg_action(au, av, u, v, phi, phisub, cs%umask, cs%vmask, hmask, &
1122 h_node, cs%ice_visc, float_cond, g%bathyT(:,:), cs%taub_beta_eff, &
1123 g%areaT, g, isc-1, iec+1, jsc-1, jec+1, cs%density_ice/cs%density_ocean_avg)
1125 call pass_vector(au, av, g%domain, to_all, bgrid_ne)
1127 ru(:,:) = rhsu(:,:) - au(:,:) ; rv(:,:) = rhsv(:,:) - av(:,:)
1129 if (.not. cs%use_reproducing_sums)
then
1133 if (cs%umask(i,j) == 1) dot_p1 = dot_p1 + ru(i,j)**2
1134 if (cs%vmask(i,j) == 1) dot_p1 = dot_p1 + rv(i,j)**2
1138 call sum_across_pes(dot_p1)
1146 if (cs%umask(i,j) == 1) sum_vec(i,j) = ru(i,j)**2
1147 if (cs%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + rv(i,j)**2
1151 dot_p1 =
reproducing_sum( sum_vec, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1152 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1156 resid0 = sqrt(dot_p1)
1160 if (cs%umask(i,j) == 1) zu(i,j) = ru(i,j) / diagu(i,j)
1161 if (cs%vmask(i,j) == 1) zv(i,j) = rv(i,j) / diagv(i,j)
1165 du(:,:) = zu(:,:) ; dv(:,:) = zv(:,:)
1180 do iter = 1,cs%cg_max_iterations
1187 is = isc - cg_halo ; ie = iecq + cg_halo
1188 js = jscq - cg_halo ; je = jecq + cg_halo
1190 au(:,:) = 0 ; av(:,:) = 0
1192 call cg_action(au, av, du, dv, phi, phisub, cs%umask, cs%vmask, hmask, &
1193 h_node, cs%ice_visc, float_cond, g%bathyT(:,:), cs%taub_beta_eff, &
1194 g%areaT, g, is, ie, js, je, cs%density_ice/cs%density_ocean_avg)
1198 if ( .not. cs%use_reproducing_sums)
then
1202 dot_p1 = 0 ; dot_p2 = 0
1205 if (cs%umask(i,j) == 1)
then
1206 dot_p1 = dot_p1 + zu(i,j)*ru(i,j)
1207 dot_p2 = dot_p2 + du(i,j)*au(i,j)
1209 if (cs%vmask(i,j) == 1)
then
1210 dot_p1 = dot_p1 + zv(i,j)*rv(i,j)
1211 dot_p2 = dot_p2 + dv(i,j)*av(i,j)
1215 call sum_across_pes(dot_p1) ;
call sum_across_pes(dot_p2)
1218 sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0
1222 if (cs%umask(i,j) == 1) sum_vec(i,j) = zu(i,j) * ru(i,j)
1223 if (cs%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + zv(i,j) * rv(i,j)
1225 if (cs%umask(i,j) == 1) sum_vec_2(i,j) = du(i,j) * au(i,j)
1226 if (cs%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + dv(i,j) * av(i,j)
1230 dot_p1 =
reproducing_sum( sum_vec, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1231 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1233 dot_p2 =
reproducing_sum( sum_vec_2, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1234 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1237 alpha_k = dot_p1/dot_p2
1241 if (cs%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * du(i,j)
1242 if (cs%vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * dv(i,j)
1248 if (cs%umask(i,j) == 1)
then
1249 ru_old(i,j) = ru(i,j) ; zu_old(i,j) = zu(i,j)
1251 if (cs%vmask(i,j) == 1)
then
1252 rv_old(i,j) = rv(i,j) ; zv_old(i,j) = zv(i,j)
1262 if (cs%umask(i,j) == 1) ru(i,j) = ru(i,j) - alpha_k * au(i,j)
1263 if (cs%vmask(i,j) == 1) rv(i,j) = rv(i,j) - alpha_k * av(i,j)
1270 if (cs%umask(i,j) == 1)
then
1271 zu(i,j) = ru(i,j) / diagu(i,j)
1273 if (cs%vmask(i,j) == 1)
then
1274 zv(i,j) = rv(i,j) / diagv(i,j)
1281 if (.not. cs%use_reproducing_sums)
then
1284 dot_p1 = 0 ; dot_p2 = 0
1287 if (cs%umask(i,j) == 1)
then
1288 dot_p1 = dot_p1 + zu(i,j)*ru(i,j)
1289 dot_p2 = dot_p2 + zu_old(i,j)*ru_old(i,j)
1291 if (cs%vmask(i,j) == 1)
then
1292 dot_p1 = dot_p1 + zv(i,j)*rv(i,j)
1293 dot_p2 = dot_p2 + zv_old(i,j)*rv_old(i,j)
1297 call sum_across_pes(dot_p1) ;
call sum_across_pes(dot_p2)
1302 sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0
1306 if (cs%umask(i,j) == 1) sum_vec(i,j) = zu(i,j) * ru(i,j)
1307 if (cs%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + &
1310 if (cs%umask(i,j) == 1) sum_vec_2(i,j) = zu_old(i,j) * ru_old(i,j)
1311 if (cs%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + &
1312 zv_old(i,j) * rv_old(i,j)
1317 dot_p1 =
reproducing_sum(sum_vec, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1318 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1320 dot_p2 =
reproducing_sum(sum_vec_2, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1321 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1325 beta_k = dot_p1/dot_p2
1333 if (cs%umask(i,j) == 1) du(i,j) = zu(i,j) + beta_k * du(i,j)
1334 if (cs%vmask(i,j) == 1) dv(i,j) = zv(i,j) + beta_k * dv(i,j)
1342 if (.not. cs%use_reproducing_sums)
then
1346 if (cs%umask(i,j) == 1)
then
1347 dot_p1 = dot_p1 + ru(i,j)**2
1349 if (cs%vmask(i,j) == 1)
then
1350 dot_p1 = dot_p1 + rv(i,j)**2
1354 call sum_across_pes(dot_p1)
1362 if (cs%umask(i,j) == 1) sum_vec(i,j) = ru(i,j)**2
1363 if (cs%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + rv(i,j)**2
1367 dot_p1 =
reproducing_sum( sum_vec, isumstart+(1-g%IsdB), iecq+(1-g%IsdB), &
1368 jsumstart+(1-g%JsdB), jecq+(1-g%JsdB) )
1371 dot_p1 = sqrt(dot_p1)
1373 if (dot_p1 <= cs%cg_tolerance * resid0)
then
1379 cg_halo = cg_halo - 1
1381 if (cg_halo == 0)
then
1383 call pass_vector(du, dv, g%domain, to_all, bgrid_ne)
1384 call pass_vector(u, v, g%domain, to_all, bgrid_ne)
1385 call pass_vector(ru, rv, g%domain, to_all, bgrid_ne)
1393 if (cs%umask(i,j) == 3)
then
1394 u(i,j) = cs%u_bdry_val(i,j)
1395 elseif (cs%umask(i,j) == 0)
then
1399 if (cs%vmask(i,j) == 3)
then
1400 v(i,j) = cs%v_bdry_val(i,j)
1401 elseif (cs%vmask(i,j) == 0)
then
1409 if (conv_flag == 0)
then
1410 iters = cs%cg_max_iterations
1413 end subroutine ice_shelf_solve_inner
1415 subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter)
1418 real,
intent(in) :: time_step
1419 real,
dimension(SZDI_(G),SZDJ_(G)), &
1420 intent(inout) :: hmask
1422 real,
dimension(SZDI_(G),SZDJ_(G)), &
1424 real,
dimension(SZDI_(G),SZDJ_(G)), &
1425 intent(inout) :: h_after_uflux
1427 real,
dimension(SZDI_(G),SZDJ_(G),4), &
1428 intent(inout) :: flux_enter
1449 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied
1450 integer :: i_off, j_off
1451 logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry
1452 real,
dimension(-2:2) :: stencil
1454 flux_diff_cell, phi, dxh, dyh, dxdyh
1455 character (len=1) :: debug_str
1457 is = g%isc-2 ; ie = g%iec+2 ; js = g%jsc ; je = g%jec
1458 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
1459 i_off = g%idg_offset ; j_off = g%jdg_offset
1462 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
1463 ((j+j_off) >= g%domain%njhalo+1))
then
1469 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
1470 ((i+i_off) >= g%domain%nihalo+1))
then
1472 if (i+i_off == g%domain%nihalo+1)
then
1475 at_west_bdry=.false.
1478 if (i+i_off == g%domain%niglobal+g%domain%nihalo)
then
1481 at_east_bdry=.false.
1484 if (hmask(i,j) == 1)
then
1486 dxh = g%dxT(i,j) ; dyh = g%dyT(i,j) ; dxdyh = g%areaT(i,j)
1488 h_after_uflux(i,j) = h0(i,j)
1490 stencil(:) = h0(i-2:i+2,j)
1496 if (cs%u_face_mask(i-1,j) == 4.)
then
1498 flux_diff_cell = flux_diff_cell + dyh * time_step * cs%u_flux_bdry_val(i-1,j) / dxdyh
1503 u_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i-1,j))
1505 if (u_face > 0)
then
1509 if (at_west_bdry .AND. (hmask(i-1,j) == 3))
then
1511 stencil(-1) = cs%thickness_bdry_val(i-1,j)
1512 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step * stencil(-1) / dxdyh
1514 elseif (hmask(i-1,j) * hmask(i-2,j) == 1)
then
1515 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
1516 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh* time_step / dxdyh * &
1517 (stencil(-1) - phi * (stencil(-1)-stencil(0))/2)
1523 flux_diff_cell = flux_diff_cell + abs(u_face) * (dyh * time_step / dxdyh) * stencil(-1)
1527 elseif (u_face < 0)
then
1528 if (hmask(i-1,j) * hmask(i+1,j) == 1)
then
1529 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
1530 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * &
1531 (stencil(0) - phi * (stencil(0)-stencil(-1))/2)
1534 flux_diff_cell = flux_diff_cell - abs(u_face) * (dyh * time_step / dxdyh) * stencil(0)
1536 if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2))
then
1537 flux_enter(i-1,j,2) = abs(u_face) * dyh * time_step * stencil(0)
1547 if (cs%u_face_mask(i+1,j) == 4.)
then
1549 flux_diff_cell = flux_diff_cell + dyh * time_step * cs%u_flux_bdry_val(i+1,j) / dxdyh
1553 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
1555 if (u_face < 0)
then
1557 if (at_east_bdry .AND. (hmask(i+1,j) == 3))
then
1560 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step * stencil(1) / dxdyh
1562 elseif (hmask(i+1,j) * hmask(i+2,j) == 1)
then
1564 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
1565 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step / dxdyh * &
1566 (stencil(1) - phi * (stencil(1)-stencil(0))/2)
1572 flux_diff_cell = flux_diff_cell + abs(u_face) * (dyh * time_step / dxdyh) * stencil(1)
1576 elseif (u_face > 0)
then
1578 if (hmask(i-1,j) * hmask(i+1,j) == 1)
then
1580 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
1581 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * &
1582 (stencil(0) - phi * (stencil(0)-stencil(1))/2)
1588 flux_diff_cell = flux_diff_cell - abs(u_face) * (dyh * time_step / dxdyh) * stencil(0)
1590 if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2))
then
1591 flux_enter(i+1,j,1) = abs(u_face) * dyh * time_step * stencil(0)
1598 h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell
1602 elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2))
then
1604 if (at_west_bdry .AND. (hmask(i-1,j) == 3))
then
1605 u_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i-1,j))
1606 flux_enter(i,j,1) = abs(u_face) * g%dyT(i,j) * time_step * cs%thickness_bdry_val(i-1,j)
1607 elseif (cs%u_face_mask(i-1,j) == 4.)
then
1608 flux_enter(i,j,1) = g%dyT(i,j) * time_step * cs%u_flux_bdry_val(i-1,j)
1611 if (at_east_bdry .AND. (hmask(i+1,j) == 3))
then
1612 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
1613 flux_enter(i,j,2) = abs(u_face) * g%dyT(i,j) * time_step * cs%thickness_bdry_val(i+1,j)
1614 elseif (cs%u_face_mask(i+1,j) == 4.)
then
1615 flux_enter(i,j,2) = g%dyT(i,j) * time_step * cs%u_flux_bdry_val(i+1,j)
1618 if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1))
then
1624 elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1))
then
1643 end subroutine ice_shelf_advect_thickness_x
1645 subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter)
1648 real,
intent(in) :: time_step
1649 real,
dimension(SZDI_(G),SZDJ_(G)), &
1650 intent(inout) :: hmask
1652 real,
dimension(SZDI_(G),SZDJ_(G)), &
1653 intent(in) :: h_after_uflux
1655 real,
dimension(SZDI_(G),SZDJ_(G)), &
1656 intent(inout) :: h_after_vflux
1658 real,
dimension(SZDI_(G),SZDJ_(G),4), &
1659 intent(inout) :: flux_enter
1680 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied
1681 integer :: i_off, j_off
1682 logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry
1683 real,
dimension(-2:2) :: stencil
1685 flux_diff_cell, phi, dxh, dyh, dxdyh
1686 character(len=1) :: debug_str
1688 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
1689 i_off = g%idg_offset ; j_off = g%jdg_offset
1692 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
1693 ((i+i_off) >= g%domain%nihalo+1))
then
1699 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
1700 ((j+j_off) >= g%domain%njhalo+1))
then
1702 if (j+j_off == g%domain%njhalo+1)
then
1703 at_south_bdry=.true.
1705 at_south_bdry=.false.
1708 if (j+j_off == g%domain%njglobal+g%domain%njhalo)
then
1709 at_north_bdry=.true.
1711 at_north_bdry=.false.
1714 if (hmask(i,j) == 1)
then
1715 dxh = g%dxT(i,j) ; dyh = g%dyT(i,j) ; dxdyh = g%areaT(i,j)
1716 h_after_vflux(i,j) = h_after_uflux(i,j)
1718 stencil(:) = h_after_uflux(i,j-2:j+2)
1723 if (cs%v_face_mask(i,j-1) == 4.)
then
1725 flux_diff_cell = flux_diff_cell + dxh * time_step * cs%v_flux_bdry_val(i,j-1) / dxdyh
1730 v_face = 0.5 * (cs%v_shelf(i-1,j-1) + cs%v_shelf(i,j-1))
1732 if (v_face > 0)
then
1736 if (at_south_bdry .AND. (hmask(i,j-1) == 3))
then
1738 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step * stencil(-1) / dxdyh
1740 elseif (hmask(i,j-1) * hmask(i,j-2) == 1)
then
1742 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
1743 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * &
1744 (stencil(-1) - phi * (stencil(-1)-stencil(0))/2)
1749 flux_diff_cell = flux_diff_cell + abs(v_face) * (dxh * time_step / dxdyh) * stencil(-1)
1752 elseif (v_face < 0)
then
1754 if (hmask(i,j-1) * hmask(i,j+1) == 1)
then
1755 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
1756 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * &
1757 (stencil(0) - phi * (stencil(0)-stencil(-1))/2)
1759 flux_diff_cell = flux_diff_cell - abs(v_face) * (dxh * time_step / dxdyh) * stencil(0)
1761 if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2))
then
1762 flux_enter(i,j-1,4) = abs(v_face) * dyh * time_step * stencil(0)
1773 if (cs%v_face_mask(i,j+1) == 4.)
then
1775 flux_diff_cell = flux_diff_cell + dxh * time_step * cs%v_flux_bdry_val(i,j+1) / dxdyh
1780 v_face = 0.5 * (cs%v_shelf(i-1,j) + cs%v_shelf(i,j))
1782 if (v_face < 0)
then
1784 if (at_north_bdry .AND. (hmask(i,j+1) == 3))
then
1786 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step * stencil(1) / dxdyh
1787 elseif (hmask(i,j+1) * hmask(i,j+2) == 1)
then
1788 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
1789 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * &
1790 (stencil(1) - phi * (stencil(1)-stencil(0))/2)
1794 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * stencil(1)
1797 elseif (v_face > 0)
then
1799 if (hmask(i,j-1) * hmask(i,j+1) == 1)
then
1800 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
1801 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * &
1802 (stencil(0) - phi * (stencil(0)-stencil(1))/2)
1806 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * stencil(0)
1807 if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2))
then
1808 flux_enter(i,j+1,3) = abs(v_face) * dxh * time_step * stencil(0)
1816 h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell
1818 elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2))
then
1820 if (at_south_bdry .AND. (hmask(i,j-1) == 3))
then
1821 v_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i,j-1))
1822 flux_enter(i,j,3) = abs(v_face) * g%dxT(i,j) * time_step * cs%thickness_bdry_val(i,j-1)
1823 elseif (cs%v_face_mask(i,j-1) == 4.)
then
1824 flux_enter(i,j,3) = g%dxT(i,j) * time_step * cs%v_flux_bdry_val(i,j-1)
1827 if (at_north_bdry .AND. (hmask(i,j+1) == 3))
then
1828 v_face = 0.5 * (cs%u_shelf(i-1,j) + cs%u_shelf(i,j))
1829 flux_enter(i,j,4) = abs(v_face) * g%dxT(i,j) * time_step * cs%thickness_bdry_val(i,j+1)
1830 elseif (cs%v_face_mask(i,j+1) == 4.)
then
1831 flux_enter(i,j,4) = g%dxT(i,j) * time_step * cs%v_flux_bdry_val(i,j+1)
1834 if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1))
then
1839 elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1))
then
1852 end subroutine ice_shelf_advect_thickness_y
1854 subroutine shelf_advance_front(CS, ISS, G, flux_enter)
1859 real,
dimension(SZDI_(G),SZDJ_(G),4), &
1860 intent(inout) :: flux_enter
1890 integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count
1891 integer :: i_off, j_off
1892 integer :: iter_flag
1894 real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux
1895 character(len=160) :: mesg
1896 integer,
dimension(4) :: mapi, mapj, new_partial
1898 real,
dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace
1900 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
1901 i_off = g%idg_offset ; j_off = g%jdg_offset
1902 rho = cs%density_ice
1903 iter_count = 0 ; iter_flag = 1
1906 mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0
1907 mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0
1909 do while (iter_flag == 1)
1913 if (iter_count > 0)
then
1914 flux_enter(:,:,:) = flux_enter_replace(:,:,:)
1916 flux_enter_replace(:,:,:) = 0.0
1918 iter_count = iter_count + 1
1924 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
1925 ((j+j_off) >= g%domain%njhalo+1))
then
1929 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
1930 ((i+i_off) >= g%domain%nihalo+1))
then
1937 if (flux_enter(i,j,k) > 0)
then
1939 h_reference = h_reference + iss%h_shelf(i+2*k-3,j)
1940 tot_flux = tot_flux + flux_enter(i,j,k)
1941 flux_enter(i,j,k) = 0.0
1946 if (flux_enter(i,j,k+2) > 0)
then
1948 h_reference = h_reference + iss%h_shelf(i,j+2*k-3)
1949 tot_flux = tot_flux + flux_enter(i,j,k+2)
1950 flux_enter(i,j,k+2) = 0.0
1954 if (n_flux > 0)
then
1955 dxdyh = g%areaT(i,j)
1956 h_reference = h_reference / real(n_flux)
1957 partial_vol = iss%h_shelf(i,j) * iss%area_shelf_h(i,j) + tot_flux
1959 if ((partial_vol / dxdyh) == h_reference)
then
1961 iss%h_shelf(i,j) = h_reference
1962 iss%area_shelf_h(i,j) = dxdyh
1963 elseif ((partial_vol / dxdyh) < h_reference)
then
1966 iss%area_shelf_h(i,j) = partial_vol / h_reference
1967 iss%h_shelf(i,j) = h_reference
1971 iss%area_shelf_h(i,j) = dxdyh
1973 partial_vol = partial_vol - h_reference * dxdyh
1977 n_flux = 0 ; new_partial(:) = 0
1980 if (cs%u_face_mask(i-2+k,j) == 2)
then
1982 elseif (iss%hmask(i+2*k-3,j) == 0)
then
1988 if (cs%v_face_mask(i,j-2+k) == 2)
then
1990 elseif (iss%hmask(i,j+2*k-3) == 0)
then
1992 new_partial(k+2) = 1
1996 if (n_flux == 0)
then
1997 iss%h_shelf(i,j) = h_reference + partial_vol / dxdyh
1999 iss%h_shelf(i,j) = h_reference
2002 if (new_partial(k) == 1) &
2003 flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux)
2006 if (new_partial(k+2) == 1) &
2007 flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux)
2023 call max_across_pes(iter_count)
2025 if (is_root_pe() .and. (iter_count > 1))
then
2026 write(mesg,*)
"shelf_advance_front: ", iter_count,
" max iterations"
2027 call mom_mesg(mesg, 5)
2030 end subroutine shelf_advance_front
2033 subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve)
2035 real,
dimension(SZDI_(G),SZDJ_(G)), &
2036 intent(inout) :: h_shelf
2037 real,
dimension(SZDI_(G),SZDJ_(G)), &
2038 intent(inout) :: area_shelf_h
2039 real,
dimension(SZDI_(G),SZDJ_(G)), &
2040 intent(inout) :: hmask
2042 real,
intent(in) :: thickness_calve
2050 if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.))
then
2052 area_shelf_h(i,j) = 0.0
2058 end subroutine ice_shelf_min_thickness_calve
2060 subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask)
2062 real,
dimension(SZDI_(G),SZDJ_(G)), &
2063 intent(inout) :: h_shelf
2064 real,
dimension(SZDI_(G),SZDJ_(G)), &
2065 intent(inout) :: area_shelf_h
2066 real,
dimension(SZDI_(G),SZDJ_(G)), &
2067 intent(inout) :: hmask
2069 real,
dimension(SZDI_(G),SZDJ_(G)), &
2070 intent(in) :: calve_mask
2075 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
2076 if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0))
then
2078 area_shelf_h(i,j) = 0.0
2083 end subroutine calve_to_mask
2085 subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD)
2091 real,
dimension(SZDI_(G),SZDJ_(G)), &
2093 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2094 intent(inout) :: TAUD_X
2095 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2096 intent(inout) :: TAUD_Y
2109 real,
dimension(SIZE(OD,1),SIZE(OD,2)) :: S, &
2113 real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav
2115 integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq
2116 integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec
2117 integer :: i_off, j_off
2119 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
2120 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
2121 isd = g%isd ; jsd = g%jsd
2122 iegq = g%iegB ; jegq = g%jegB
2123 gisc = g%domain%nihalo+1 ; gjsc = g%domain%njhalo+1
2124 giec = g%domain%niglobal+g%domain%nihalo ; gjec = g%domain%njglobal+g%domain%njhalo
2125 is = iscq - 1; js = jscq - 1
2126 i_off = g%idg_offset ; j_off = g%jdg_offset
2128 rho = cs%density_ice
2129 rhow = cs%density_ocean_avg
2130 grav = us%Z_to_m**2 * cs%g_Earth
2135 base(:,:) = -g%bathyT(:,:) + od(:,:)
2136 s(:,:) = base(:,:) + iss%h_shelf(:,:)
2145 dxdyh = g%areaT(i,j)
2147 if (iss%hmask(i,j) == 1)
then
2150 if ((i+i_off) == gisc)
then
2151 if (iss%hmask(i+1,j) == 1)
then
2152 sx = (s(i+1,j)-s(i,j))/dxh
2156 elseif ((i+i_off) == giec)
then
2157 if (iss%hmask(i-1,j) == 1)
then
2158 sx = (s(i,j)-s(i-1,j))/dxh
2163 if (iss%hmask(i+1,j) == 1)
then
2169 if (iss%hmask(i-1,j) == 1)
then
2178 sx = sx / (cnt * dxh)
2185 if ((j+j_off) == gjsc)
then
2186 if (iss%hmask(i,j+1) == 1)
then
2187 sy = (s(i,j+1)-s(i,j))/dyh
2191 elseif ((j+j_off) == gjec)
then
2192 if (iss%hmask(i,j-1) == 1)
then
2193 sy = (s(i,j)-s(i,j-1))/dyh
2198 if (iss%hmask(i,j+1) == 1)
then
2204 if (iss%hmask(i,j-1) == 1)
then
2213 sy = sy / (cnt * dyh)
2218 taud_x(i-1,j-1) = taud_x(i-1,j-1) - .25 * rho * grav * iss%h_shelf(i,j) * sx * dxdyh
2219 taud_y(i-1,j-1) = taud_y(i-1,j-1) - .25 * rho * grav * iss%h_shelf(i,j) * sy * dxdyh
2222 taud_x(i,j-1) = taud_x(i,j-1) - .25 * rho * grav * iss%h_shelf(i,j) * sx * dxdyh
2223 taud_y(i,j-1) = taud_y(i,j-1) - .25 * rho * grav * iss%h_shelf(i,j) * sy * dxdyh
2226 taud_x(i-1,j) = taud_x(i-1,j) - .25 * rho * grav * iss%h_shelf(i,j) * sx * dxdyh
2227 taud_y(i-1,j) = taud_y(i-1,j) - .25 * rho * grav * iss%h_shelf(i,j) * sy * dxdyh
2230 taud_x(i,j) = taud_x(i,j) - .25 * rho * grav * iss%h_shelf(i,j) * sx * dxdyh
2231 taud_y(i,j) = taud_y(i,j) - .25 * rho * grav * iss%h_shelf(i,j) * sy * dxdyh
2233 if (cs%float_frac(i,j) == 1)
then
2234 neumann_val = .5 * grav * (rho * iss%h_shelf(i,j)**2 - rhow * g%bathyT(i,j)**2)
2236 neumann_val = .5 * grav * (1-rho/rhow) * rho * iss%h_shelf(i,j)**2
2240 if ((cs%u_face_mask(i-1,j) == 2) .OR. (iss%hmask(i-1,j) == 0) .OR. (iss%hmask(i-1,j) == 2) )
then
2250 taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val
2251 taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val
2254 if ((cs%u_face_mask(i,j) == 2) .OR. (iss%hmask(i+1,j) == 0) .OR. (iss%hmask(i+1,j) == 2) )
then
2256 taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val
2257 taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val
2260 if ((cs%v_face_mask(i,j-1) == 2) .OR. (iss%hmask(i,j-1) == 0) .OR. (iss%hmask(i,j-1) == 2) )
then
2262 taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val
2263 taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val
2266 if ((cs%v_face_mask(i,j) == 2) .OR. (iss%hmask(i,j+1) == 0) .OR. (iss%hmask(i,j+1) == 2) )
then
2268 taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val
2269 taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val
2276 end subroutine calc_shelf_driving_stress
2278 subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim)
2281 type(time_type),
intent(in) :: Time
2282 real,
dimension(SZDI_(G),SZDJ_(G)), &
2285 real,
intent(in) :: input_flux
2286 real,
intent(in) :: input_thick
2287 logical,
optional,
intent(in) :: new_sim
2296 integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq
2297 integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec
2298 integer :: i_off, j_off
2299 real :: A, n, ux, uy, vx, vy, eps_min, domain_width
2302 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
2304 isd = g%isd ; jsd = g%jsd ; ied = g%ied ; jed = g%jed
2306 i_off = g%idg_offset ; j_off = g%jdg_offset
2308 domain_width = g%len_lat
2315 if (hmask(i,j) == 3)
then
2316 cs%thickness_bdry_val(i,j) = input_thick
2319 if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2))
then
2320 if ((i <= iec).and.(i >= isc))
then
2321 if (cs%u_face_mask(i-1,j) == 3)
then
2322 cs%u_bdry_val(i-1,j-1) = (1 - ((g%geoLatBu(i-1,j-1) - 0.5*g%len_lat)*2./g%len_lat)**2) * &
2323 1.5 * input_flux / input_thick
2324 cs%u_bdry_val(i-1,j) = (1 - ((g%geoLatBu(i-1,j) - 0.5*g%len_lat)*2./g%len_lat)**2) * &
2325 1.5 * input_flux / input_thick
2330 if (.not.(new_sim))
then
2331 if (.not. g%symmetric)
then
2332 if (((i+i_off) == (g%domain%nihalo+1)).and.(cs%u_face_mask(i-1,j) == 3))
then
2333 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
2334 cs%u_shelf(i-1,j) = cs%u_bdry_val(i-1,j)
2336 if (((j+j_off) == (g%domain%njhalo+1)).and.(cs%v_face_mask(i,j-1) == 3))
then
2337 cs%u_shelf(i-1,j-1) = cs%u_bdry_val(i-1,j-1)
2338 cs%u_shelf(i,j-1) = cs%u_bdry_val(i,j-1)
2345 end subroutine init_boundary_values
2348 subroutine cg_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, &
2349 nu, float_cond, bathyT, beta, dxdyh, G, is, ie, js, je, dens_ratio)
2352 real,
dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
2353 intent(inout) :: uret
2354 real,
dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
2355 intent(inout) :: vret
2356 real,
dimension(SZDI_(G),SZDJ_(G),8,4), &
2359 real,
dimension(:,:,:,:,:,:), &
2360 intent(in) :: Phisub
2362 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2364 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2366 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2369 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2372 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2373 intent(in) :: H_node
2375 real,
dimension(SZDI_(G),SZDJ_(G)), &
2378 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2382 real,
dimension(SZDI_(G),SZDJ_(G)), &
2383 intent(in) :: float_cond
2385 real,
dimension(SZDI_(G),SZDJ_(G)), &
2386 intent(in) :: bathyT
2387 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2392 real,
dimension(SZDI_(G),SZDJ_(G)), &
2394 real,
intent(in) :: dens_ratio
2396 integer,
intent(in) :: is
2397 integer,
intent(in) :: ie
2398 integer,
intent(in) :: js
2399 integer,
intent(in) :: je
2420 real :: ux, vx, uy, vy, uq, vq, area, basel
2421 integer :: iq, jq, iphi, jphi, i, j, ilq, jlq
2422 real,
dimension(2) :: xquad
2423 real,
dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr
2425 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
2428 do i=is,ie ;
if (hmask(i,j) == 1)
then
2447 do iq=1,2 ;
do jq=1,2
2462 uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + &
2463 u(i,j-1) * xquad(iq) * xquad(3-jq) + &
2464 u(i-1,j) * xquad(3-iq) * xquad(jq) + &
2465 u(i,j) * xquad(iq) * xquad(jq)
2467 vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + &
2468 v(i,j-1) * xquad(iq) * xquad(3-jq) + &
2469 v(i-1,j) * xquad(3-iq) * xquad(jq) + &
2470 v(i,j) * xquad(iq) * xquad(jq)
2472 ux = u(i-1,j-1) * phi(i,j,1,2*(jq-1)+iq) + &
2473 u(i,j-1) * phi(i,j,3,2*(jq-1)+iq) + &
2474 u(i-1,j) * phi(i,j,5,2*(jq-1)+iq) + &
2475 u(i,j) * phi(i,j,7,2*(jq-1)+iq)
2477 vx = v(i-1,j-1) * phi(i,j,1,2*(jq-1)+iq) + &
2478 v(i,j-1) * phi(i,j,3,2*(jq-1)+iq) + &
2479 v(i-1,j) * phi(i,j,5,2*(jq-1)+iq) + &
2480 v(i,j) * phi(i,j,7,2*(jq-1)+iq)
2482 uy = u(i-1,j-1) * phi(i,j,2,2*(jq-1)+iq) + &
2483 u(i,j-1) * phi(i,j,4,2*(jq-1)+iq) + &
2484 u(i-1,j) * phi(i,j,6,2*(jq-1)+iq) + &
2485 u(i,j) * phi(i,j,8,2*(jq-1)+iq)
2487 vy = v(i-1,j-1) * phi(i,j,2,2*(jq-1)+iq) + &
2488 v(i,j-1) * phi(i,j,4,2*(jq-1)+iq) + &
2489 v(i-1,j) * phi(i,j,6,2*(jq-1)+iq) + &
2490 v(i,j) * phi(i,j,8,2*(jq-1)+iq)
2492 do iphi=1,2 ;
do jphi=1,2
2493 if (umask(i-2+iphi,j-2+jphi) == 1)
then
2495 uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + &
2496 .25 * area * nu(i,j) * ((4*ux+2*vy) * phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2497 (uy+vx) * phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq))
2499 if (vmask(i-2+iphi,j-2+jphi) == 1)
then
2501 vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + &
2502 .25 * area * nu(i,j) * ((uy+vx) * phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2503 (4*vy+2*ux) * phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq))
2506 if (iq == iphi)
then
2512 if (jq == jphi)
then
2518 if (float_cond(i,j) == 0)
then
2520 if (umask(i-2+iphi,j-2+jphi) == 1)
then
2522 uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + &
2523 .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq)
2527 if (vmask(i-2+iphi,j-2+jphi) == 1)
then
2529 vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + &
2530 .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq)
2535 ucontr(iphi,jphi) = ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j)
2539 if (float_cond(i,j) == 1)
then
2540 usubcontr = 0.0 ; vsubcontr = 0.0 ; basel = bathyt(i,j)
2541 ucell(:,:) = u(i-1:i,j-1:j) ; vcell(:,:) = v(i-1:i,j-1:j) ; hcell(:,:) = h_node(i-1:i,j-1:j)
2542 call cg_action_subgrid_basal(phisub, hcell, ucell, vcell, area, basel, &
2543 dens_ratio, usubcontr, vsubcontr)
2544 do iphi=1,2 ;
do jphi=1,2
2545 if (umask(i-2+iphi,j-2+jphi) == 1)
then
2546 uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + usubcontr(iphi,jphi) * beta(i,j)
2548 if (vmask(i-2+iphi,j-2+jphi) == 1)
then
2549 vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + vsubcontr(iphi,jphi) * beta(i,j)
2557 end subroutine cg_action
2559 subroutine cg_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr)
2560 real,
dimension(:,:,:,:,:,:), &
2561 intent(in) :: Phisub
2563 real,
dimension(2,2),
intent(in) :: H
2564 real,
dimension(2,2),
intent(in) :: U
2565 real,
dimension(2,2),
intent(in) :: V
2566 real,
intent(in) :: DXDYH
2567 real,
intent(in) :: bathyT
2568 real,
intent(in) :: dens_ratio
2570 real,
dimension(2,2),
intent(inout) :: Ucontr
2572 real,
dimension(2,2),
intent(inout) :: Vcontr
2575 integer :: nsub, i, j, k, l, qx, qy, m, n
2576 real :: subarea, hloc, uq, vq
2578 nsub =
size(phisub,1)
2579 subarea = dxdyh / (nsub**2)
2588 hloc = phisub(i,j,1,1,qx,qy)*h(1,1) + phisub(i,j,1,2,qx,qy)*h(1,2) + &
2589 phisub(i,j,2,1,qx,qy)*h(2,1) + phisub(i,j,2,2,qx,qy)*h(2,2)
2591 if (dens_ratio * hloc - bathyt > 0)
then
2598 uq = uq + phisub(i,j,k,l,qx,qy) * u(k,l) ; vq = vq + phisub(i,j,k,l,qx,qy) * v(k,l)
2602 ucontr(m,n) = ucontr(m,n) + subarea * 0.25 * phisub(i,j,m,n,qx,qy) * uq
2603 vcontr(m,n) = vcontr(m,n) + subarea * 0.25 * phisub(i,j,m,n,qx,qy) * vq
2614 end subroutine cg_action_subgrid_basal
2617 subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, &
2618 Phisub, u_diagonal, v_diagonal)
2622 real,
dimension(SZDI_(G),SZDJ_(G)), &
2623 intent(in) :: float_cond
2625 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2626 intent(in) :: H_node
2628 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2632 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2636 real,
dimension(SZDI_(G),SZDJ_(G)), &
2639 real,
intent(in) :: dens_ratio
2641 real,
dimension(:,:,:,:,:,:),
intent(in) :: Phisub
2643 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2644 intent(inout) :: u_diagonal
2646 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2647 intent(inout) :: v_diagonal
2653 integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq
2654 real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel
2655 real,
dimension(8,4) :: Phi
2656 real,
dimension(4) :: X, Y
2657 real,
dimension(2) :: xquad
2658 real,
dimension(2,2) :: Hcell,Usubcontr,Vsubcontr
2661 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
2663 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
2672 do j=jsc-1,jec+1 ;
do i=isc-1,iec+1 ;
if (hmask(i,j) == 1)
then
2676 dxdyh = g%areaT(i,j)
2678 x(1:2) = g%geoLonBu(i-1:i,j-1)*1000
2679 x(3:4) = g%geoLonBu(i-1:i,j) *1000
2680 y(1:2) = g%geoLatBu(i-1:i,j-1) *1000
2681 y(3:4) = g%geoLatBu(i-1:i,j)*1000
2683 call bilinear_shape_functions(x, y, phi, area)
2692 do iq=1,2 ;
do jq=1,2
2694 do iphi=1,2 ;
do jphi=1,2
2696 if (iq == iphi)
then
2702 if (jq == jphi)
then
2708 if (cs%umask(i-2+iphi,j-2+jphi) == 1)
then
2710 ux = phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq)
2711 uy = phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq)
2715 u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + &
2716 .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2717 (uy+vy) * phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq))
2719 uq = xquad(ilq) * xquad(jlq)
2721 if (float_cond(i,j) == 0)
then
2722 u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + &
2723 .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq)
2728 if (cs%vmask(i-2+iphi,j-2+jphi) == 1)
then
2730 vx = phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq)
2731 vy = phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq)
2735 v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + &
2736 .25 * dxdyh * nu(i,j) * ((uy+vx) * phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2737 (4*vy+2*ux) * phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq))
2739 vq = xquad(ilq) * xquad(jlq)
2741 if (float_cond(i,j) == 0)
then
2742 v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + &
2743 .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq)
2749 if (float_cond(i,j) == 1)
then
2750 usubcontr = 0.0 ; vsubcontr = 0.0 ; basel = g%bathyT(i,j)
2751 hcell(:,:) = h_node(i-1:i,j-1:j)
2752 call cg_diagonal_subgrid_basal(phisub, hcell, dxdyh, basel, dens_ratio, usubcontr, vsubcontr)
2753 do iphi=1,2 ;
do jphi=1,2
2754 if (cs%umask(i-2+iphi,j-2+jphi) == 1)
then
2755 u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + usubcontr(iphi,jphi) * beta(i,j)
2756 v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + vsubcontr(iphi,jphi) * beta(i,j)
2760 endif ;
enddo ;
enddo
2762 end subroutine matrix_diagonal
2764 subroutine cg_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr)
2765 real,
dimension(:,:,:,:,:,:), &
2766 intent(in) :: Phisub
2768 real,
dimension(2,2),
intent(in) :: H_node
2770 real,
intent(in) :: DXDYH
2771 real,
intent(in) :: bathyT
2772 real,
intent(in) :: dens_ratio
2774 real,
dimension(2,2),
intent(inout) :: Ucontr
2776 real,
dimension(2,2),
intent(inout) :: Vcontr
2781 integer :: nsub, i, j, k, l, qx, qy, m, n
2782 real :: subarea, hloc
2784 nsub =
size(phisub,1)
2785 subarea = dxdyh / (nsub**2)
2787 do m=1,2 ;
do n=1,2 ;
do j=1,nsub ;
do i=1,nsub ;
do qx=1,2 ;
do qy = 1,2
2789 hloc = phisub(i,j,1,1,qx,qy)*h_node(1,1) + phisub(i,j,1,2,qx,qy)*h_node(1,2) + &
2790 phisub(i,j,2,1,qx,qy)*h_node(2,1) + phisub(i,j,2,2,qx,qy)*h_node(2,2)
2792 if (dens_ratio * hloc - bathyt > 0)
then
2793 ucontr(m,n) = ucontr(m,n) + subarea * 0.25 * phisub(i,j,m,n,qx,qy)**2
2794 vcontr(m,n) = vcontr(m,n) + subarea * 0.25 * phisub(i,j,m,n,qx,qy)**2
2797 enddo ;
enddo ;
enddo ;
enddo ;
enddo ;
enddo
2799 end subroutine cg_diagonal_subgrid_basal
2802 subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, &
2803 dens_ratio, u_bdry_contr, v_bdry_contr)
2809 type(time_type),
intent(in) :: Time
2810 real,
dimension(:,:,:,:,:,:), &
2811 intent(in) :: Phisub
2813 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2814 intent(in) :: H_node
2816 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2820 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2824 real,
dimension(SZDI_(G),SZDJ_(G)), &
2825 intent(in) :: float_cond
2827 real,
intent(in) :: dens_ratio
2829 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2830 intent(inout) :: u_bdry_contr
2832 real,
dimension(SZDIB_(G),SZDJB_(G)), &
2833 intent(inout) :: v_bdry_contr
2839 real,
dimension(8,4) :: Phi
2840 real,
dimension(4) :: X, Y
2841 real,
dimension(2) :: xquad
2842 integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq
2843 real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel
2844 real,
dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr
2847 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
2849 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
2858 do j=jsc-1,jec+1 ;
do i=isc-1,iec+1 ;
if (iss%hmask(i,j) == 1)
then
2863 if ((cs%umask(i-1,j-1) == 3) .OR. (cs%umask(i,j-1) == 3) .OR. &
2864 (cs%umask(i-1,j) == 3) .OR. (cs%umask(i,j) == 3))
then
2869 dxdyh = g%areaT(i,j)
2871 x(1:2) = g%geoLonBu(i-1:i,j-1)*1000
2872 x(3:4) = g%geoLonBu(i-1:i,j)*1000
2873 y(1:2) = g%geoLatBu(i-1:i,j-1)*1000
2874 y(3:4) = g%geoLatBu(i-1:i,j)*1000
2876 call bilinear_shape_functions(x, y, phi, area)
2887 do iq=1,2 ;
do jq=1,2
2889 uq = cs%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + &
2890 cs%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + &
2891 cs%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + &
2892 cs%u_bdry_val(i,j) * xquad(iq) * xquad(jq)
2894 vq = cs%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + &
2895 cs%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + &
2896 cs%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + &
2897 cs%v_bdry_val(i,j) * xquad(iq) * xquad(jq)
2899 ux = cs%u_bdry_val(i-1,j-1) * phi(1,2*(jq-1)+iq) + &
2900 cs%u_bdry_val(i,j-1) * phi(3,2*(jq-1)+iq) + &
2901 cs%u_bdry_val(i-1,j) * phi(5,2*(jq-1)+iq) + &
2902 cs%u_bdry_val(i,j) * phi(7,2*(jq-1)+iq)
2904 vx = cs%v_bdry_val(i-1,j-1) * phi(1,2*(jq-1)+iq) + &
2905 cs%v_bdry_val(i,j-1) * phi(3,2*(jq-1)+iq) + &
2906 cs%v_bdry_val(i-1,j) * phi(5,2*(jq-1)+iq) + &
2907 cs%v_bdry_val(i,j) * phi(7,2*(jq-1)+iq)
2909 uy = cs%u_bdry_val(i-1,j-1) * phi(2,2*(jq-1)+iq) + &
2910 cs%u_bdry_val(i,j-1) * phi(4,2*(jq-1)+iq) + &
2911 cs%u_bdry_val(i-1,j) * phi(6,2*(jq-1)+iq) + &
2912 cs%u_bdry_val(i,j) * phi(8,2*(jq-1)+iq)
2914 vy = cs%v_bdry_val(i-1,j-1) * phi(2,2*(jq-1)+iq) + &
2915 cs%v_bdry_val(i,j-1) * phi(4,2*(jq-1)+iq) + &
2916 cs%v_bdry_val(i-1,j) * phi(6,2*(jq-1)+iq) + &
2917 cs%v_bdry_val(i,j) * phi(8,2*(jq-1)+iq)
2919 do iphi=1,2 ;
do jphi=1,2
2921 if (iq == iphi)
then
2927 if (jq == jphi)
then
2933 if (cs%umask(i-2+iphi,j-2+jphi) == 1)
then
2936 u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + &
2937 .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2938 (uy+vx) * phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) )
2940 if (float_cond(i,j) == 0)
then
2941 u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + &
2942 .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq)
2947 if (cs%vmask(i-2+iphi,j-2+jphi) == 1)
then
2950 v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + &
2951 .25 * dxdyh * nu(i,j) * ( (uy+vx) * phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + &
2952 (4*vy+2*ux) * phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq))
2954 if (float_cond(i,j) == 0)
then
2955 v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + &
2956 .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq)
2963 if (float_cond(i,j) == 1)
then
2964 usubcontr = 0.0 ; vsubcontr = 0.0 ; basel = g%bathyT(i,j)
2965 ucell(:,:) = cs%u_bdry_val(i-1:i,j-1:j) ; vcell(:,:) = cs%v_bdry_val(i-1:i,j-1:j)
2966 hcell(:,:) = h_node(i-1:i,j-1:j)
2967 call cg_action_subgrid_basal(phisub, hcell, ucell, vcell, dxdyh, basel, &
2968 dens_ratio, usubcontr, vsubcontr)
2969 do iphi=1,2 ;
do jphi = 1,2
2970 if (cs%umask(i-2+iphi,j-2+jphi) == 1)
then
2971 u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + &
2972 usubcontr(iphi,jphi) * beta(i,j)
2974 if (cs%vmask(i-2+iphi,j-2+jphi) == 1)
then
2975 v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + &
2976 vsubcontr(iphi,jphi) * beta(i,j)
2981 endif ;
enddo ;
enddo
2983 end subroutine apply_boundary_values
2987 subroutine calc_shelf_visc(CS, ISS, G, US, u, v)
2993 real,
dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
2995 real,
dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), &
3005 integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq
3006 integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js
3007 real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh
3009 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
3010 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
3011 isd = g%isd ; jsd = g%jsd ; ied = g%ied ; jed = g%jed
3012 iegq = g%iegB ; jegq = g%jegB
3013 gisc = g%domain%nihalo+1 ; gjsc = g%domain%njhalo+1
3014 giec = g%domain%niglobal+gisc ; gjec = g%domain%njglobal+gjsc
3015 is = iscq - 1; js = jscq - 1
3017 a = cs%A_glen_isothermal ; n = cs%n_glen; eps_min = cs%eps_glen_min
3018 c_basal_friction = cs%C_basal_friction ; n_basal_friction = cs%n_basal_friction
3025 dxdyh = g%areaT(i,j)
3027 if (iss%hmask(i,j) == 1)
then
3028 ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh)
3029 vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh)
3030 uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh)
3031 vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh)
3033 cs%ice_visc(i,j) = .5 * a**(-1/n) * &
3034 (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * &
3035 us%Z_to_m*iss%h_shelf(i,j)
3037 umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4
3038 vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4
3039 unorm = sqrt(umid**2+vmid**2+(eps_min*dxh)**2)
3040 cs%taub_beta_eff(i,j) = c_basal_friction * unorm ** (n_basal_friction-1)
3045 end subroutine calc_shelf_visc
3047 subroutine update_od_ffrac(CS, G, US, ocean_mass, find_avg)
3051 real,
dimension(SZDI_(G),SZDJ_(G)), &
3052 intent(in) :: ocean_mass
3053 logical,
intent(in) :: find_avg
3056 integer :: isc, iec, jsc, jec, i, j
3060 i_rho_ocean = 1.0 / (us%Z_to_m*cs%density_ocean_avg)
3062 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
3064 do j=jsc,jec ;
do i=isc,iec
3065 cs%OD_rt(i,j) = cs%OD_rt(i,j) + ocean_mass(i,j)*i_rho_ocean
3066 if (ocean_mass(i,j)*i_rho_ocean > cs%thresh_float_col_depth)
then
3067 cs%float_frac_rt(i,j) = cs%float_frac_rt(i,j) + 1.0
3070 cs%OD_rt_counter = cs%OD_rt_counter + 1
3073 i_counter = 1.0 / real(cs%OD_rt_counter)
3074 do j=jsc,jec ;
do i=isc,iec
3075 cs%float_frac(i,j) = 1.0 - (cs%float_frac_rt(i,j) * i_counter)
3076 cs%OD_av(i,j) = cs%OD_rt(i,j) * i_counter
3078 cs%OD_rt(i,j) = 0.0 ; cs%float_frac_rt(i,j) = 0.0
3081 call pass_var(cs%float_frac, g%domain)
3085 end subroutine update_od_ffrac
3087 subroutine update_od_ffrac_uncoupled(CS, G, h_shelf)
3090 real,
dimension(SZDI_(G),SZDJ_(G)), &
3091 intent(in) :: h_shelf
3093 integer :: i, j, iters, isd, ied, jsd, jed
3094 real :: rhoi_rhow, OD
3096 rhoi_rhow = cs%density_ice / cs%density_ocean_avg
3097 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
3101 od = g%bathyT(i,j) - rhoi_rhow * h_shelf(i,j)
3105 cs%float_frac(i,j) = 0.
3108 cs%float_frac(i,j) = 1.
3113 end subroutine update_od_ffrac_uncoupled
3118 subroutine bilinear_shape_functions (X, Y, Phi, area)
3119 real,
dimension(4),
intent(in) :: X
3120 real,
dimension(4),
intent(in) :: Y
3121 real,
dimension(8,4),
intent(inout) :: Phi
3123 real,
intent(out) :: area
3142 real,
dimension(4) :: xquad, yquad
3143 integer :: node, qpoint, xnode, xq, ynode, yq
3144 real :: a,b,c,d,e,f,xexp,yexp
3146 xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3))
3147 xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3))
3151 a = -x(1)*(1-yquad(qpoint)) + x(2)*(1-yquad(qpoint)) - x(3)*yquad(qpoint) + x(4)*yquad(qpoint)
3152 b = -y(1)*(1-yquad(qpoint)) + y(2)*(1-yquad(qpoint)) - y(3)*yquad(qpoint) + y(4)*yquad(qpoint)
3153 c = -x(1)*(1-xquad(qpoint)) - x(2)*(xquad(qpoint)) + x(3)*(1-xquad(qpoint)) + x(4)*(xquad(qpoint))
3154 d = -y(1)*(1-xquad(qpoint)) - y(2)*(xquad(qpoint)) + y(3)*(1-xquad(qpoint)) + y(4)*(xquad(qpoint))
3158 xnode = 2-mod(node,2) ; ynode = ceiling(real(node)/2)
3160 if (ynode == 1)
then
3161 yexp = 1-yquad(qpoint)
3163 yexp = yquad(qpoint)
3166 if (1 == xnode)
then
3167 xexp = 1-xquad(qpoint)
3169 xexp = xquad(qpoint)
3172 phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c)
3173 phi(2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c)
3178 area = quad_area(x, y)
3180 end subroutine bilinear_shape_functions
3183 subroutine bilinear_shape_functions_subgrid(Phisub, nsub)
3184 real,
dimension(nsub,nsub,2,2,2,2), &
3185 intent(inout) :: Phisub
3187 integer,
intent(in) :: nsub
3212 integer :: i, j, k, l, qx, qy, indx, indy
3213 real,
dimension(2) :: xquad
3214 real :: x0, y0, x, y, val, fracx
3216 xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3))
3217 fracx = 1.0/real(nsub)
3221 x0 = (i-1) * fracx ; y0 = (j-1) * fracx
3224 x = x0 + fracx*xquad(qx)
3225 y = y0 + fracx*xquad(qy)
3239 phisub(i,j,k,l,qx,qy) = val
3247 end subroutine bilinear_shape_functions_subgrid
3250 subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask)
3253 real,
dimension(SZDI_(G),SZDJ_(G)), &
3256 real,
dimension(SZDIB_(G),SZDJB_(G)), &
3257 intent(out) :: umask
3259 real,
dimension(SZDIB_(G),SZDJB_(G)), &
3260 intent(out) :: vmask
3262 real,
dimension(SZDIB_(G),SZDJ_(G)), &
3263 intent(out) :: u_face_mask
3264 real,
dimension(SZDI_(G),SZDJB_(G)), &
3265 intent(out) :: v_face_mask
3271 integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq
3272 integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec
3273 integer :: i_off, j_off
3275 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
3276 iscq = g%iscB ; iecq = g%iecB ; jscq = g%jscB ; jecq = g%jecB
3277 i_off = g%idg_offset ; j_off = g%jdg_offset
3278 isd = g%isd ; jsd = g%jsd
3279 iegq = g%iegB ; jegq = g%jegB
3280 gisc = g%Domain%nihalo ; gjsc = g%Domain%njhalo
3281 giec = g%Domain%niglobal+gisc ; gjec = g%Domain%njglobal+gjsc
3283 umask(:,:) = 0 ; vmask(:,:) = 0
3284 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0
3286 if (g%symmetric)
then
3289 is = isd+1 ; js = jsd+1
3295 if (hmask(i,j) == 1)
then
3297 umask(i-1:i,j-1:j) = 1.
3298 vmask(i-1:i,j-1:j) = 1.
3302 select case (int(cs%u_face_mask_bdry(i-1+k,j)))
3304 umask(i-1+k,j-1:j)=3.
3305 vmask(i-1+k,j-1:j)=0.
3306 u_face_mask(i-1+k,j)=3.
3308 u_face_mask(i-1+k,j)=2.
3310 umask(i-1+k,j-1:j)=0.
3311 vmask(i-1+k,j-1:j)=0.
3312 u_face_mask(i-1+k,j)=4.
3314 umask(i-1+k,j-1:j)=0.
3315 vmask(i-1+k,j-1:j)=0.
3316 u_face_mask(i-1+k,j)=0.
3318 umask(i-1+k,j-1:j)=0.
3325 select case (int(cs%v_face_mask_bdry(i,j-1+k)))
3327 vmask(i-1:i,j-1+k)=3.
3328 umask(i-1:i,j-1+k)=0.
3329 v_face_mask(i,j-1+k)=3.
3331 v_face_mask(i,j-1+k)=2.
3333 umask(i-1:i,j-1+k)=0.
3334 vmask(i-1:i,j-1+k)=0.
3335 v_face_mask(i,j-1+k)=4.
3337 umask(i-1:i,j-1+k)=0.
3338 vmask(i-1:i,j-1+k)=0.
3339 u_face_mask(i,j-1+k)=0.
3341 vmask(i-1:i,j-1+k)=0.
3363 if ((hmask(i+1,j) == 0) &
3364 .OR. (hmask(i+1,j) == 2))
then
3366 u_face_mask(i,j) = 2.
3371 if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2))
then
3373 u_face_mask(i-1,j) = 2.
3378 if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2))
then
3380 v_face_mask(i,j-1) = 2.
3385 if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2))
then
3387 v_face_mask(i,j) = 2.
3400 call pass_vector(u_face_mask, v_face_mask, g%domain, to_all, cgrid_ne)
3401 call pass_vector(umask, vmask, g%domain, to_all, bgrid_ne)
3403 end subroutine update_velocity_masks
3407 subroutine interpolate_h_to_b(G, h_shelf, hmask, H_node)
3409 real,
dimension(SZDI_(G),SZDJ_(G)), &
3410 intent(in) :: h_shelf
3411 real,
dimension(SZDI_(G),SZDJ_(G)), &
3414 real,
dimension(SZDIB_(G),SZDJB_(G)), &
3415 intent(inout) :: H_node
3418 integer :: i, j, isc, iec, jsc, jec, num_h, k, l
3421 isc = g%isc ; jsc = g%jsc ; iec = g%iec ; jec = g%jec
3434 if (hmask(i+k,j+l) == 1.0)
then
3435 summ = summ + h_shelf(i+k,j+l)
3441 h_node(i,j) = summ / num_h
3446 call pass_var(h_node, g%domain, position=corner)
3448 end subroutine interpolate_h_to_b
3451 subroutine ice_shelf_dyn_end(CS)
3454 if (.not.
associated(cs))
return
3456 deallocate(cs%u_shelf, cs%v_shelf)
3457 deallocate(cs%t_shelf, cs%tmask)
3458 deallocate(cs%u_bdry_val, cs%v_bdry_val, cs%t_bdry_val)
3459 deallocate(cs%u_face_mask, cs%v_face_mask)
3460 deallocate(cs%umask, cs%vmask)
3462 deallocate(cs%ice_visc, cs%taub_beta_eff)
3463 deallocate(cs%OD_rt, cs%OD_av)
3464 deallocate(cs%float_frac, cs%float_frac_rt)
3468 end subroutine ice_shelf_dyn_end
3472 subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time)
3478 real,
intent(in) :: time_step
3479 real,
dimension(SZDI_(G),SZDJ_(G)), &
3480 intent(in) :: melt_rate
3481 type(time_type),
intent(in) :: Time
3512 real,
dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH
3513 real,
dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter
3514 integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec
3515 real :: rho, spy, t_bd, Tsurf, adot
3517 rho = cs%density_ice
3520 adot = 0.1*us%m_to_Z/spy
3523 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
3524 isc = g%isc ; iec = g%iec ; jsc = g%jsc ; jec = g%jec
3525 flux_enter(:,:,:) = 0.0
3527 th_after_uflux(:,:) = 0.0
3528 th_after_vflux(:,:) = 0.0
3532 t_bd = cs%t_bdry_val(i,j)
3534 if ((iss%hmask(i,j) == 3) .or. (iss%hmask(i,j) == -2))
then
3535 cs%t_shelf(i,j) = cs%t_bdry_val(i,j)
3542 th(i,j) = cs%t_shelf(i,j)*iss%h_shelf(i,j)
3554 call ice_shelf_advect_temp_x(cs, g, time_step/spy, iss%hmask, th, th_after_uflux, flux_enter)
3555 call ice_shelf_advect_temp_y(cs, g, time_step/spy, iss%hmask, th_after_uflux, th_after_vflux, flux_enter)
3560 if (iss%h_shelf(i,j) > 0.0)
then
3561 cs%t_shelf(i,j) = th_after_vflux(i,j)/(iss%h_shelf(i,j))
3563 cs%t_shelf(i,j) = -10.0
3570 t_bd = cs%t_bdry_val(i,j)
3572 if ((iss%hmask(i,j) == 3) .or. (iss%hmask(i,j) == -2))
then
3573 cs%t_shelf(i,j) = t_bd
3581 if ((iss%hmask(i,j) == 1) .or. (iss%hmask(i,j) == 2))
then
3582 if (iss%h_shelf(i,j) > 0.0)
then
3585 cs%t_shelf(i,j) = cs%t_shelf(i,j) + &
3586 time_step*(adot*tsurf - (3.0*us%m_to_Z/spy)*iss%tfreeze(i,j)) / iss%h_shelf(i,j)
3593 cs%t_shelf(i,j) = -10.0
3600 call pass_var(cs%t_shelf, g%domain)
3604 call hchksum(cs%t_shelf,
"temp after front", g%HI, haloshift=3)
3607 end subroutine ice_shelf_temp
3610 subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter)
3613 real,
intent(in) :: time_step
3614 real,
dimension(SZDI_(G),SZDJ_(G)), &
3617 real,
dimension(SZDI_(G),SZDJ_(G)), &
3619 real,
dimension(SZDI_(G),SZDJ_(G)), &
3620 intent(inout) :: h_after_uflux
3622 real,
dimension(SZDI_(G),SZDJ_(G),4), &
3623 intent(inout) :: flux_enter
3644 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied
3645 integer :: i_off, j_off
3646 logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry
3647 real,
dimension(-2:2) :: stencil
3649 flux_diff_cell, phi, dxh, dyh, dxdyh
3651 character (len=1) :: debug_str
3654 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
3655 i_off = g%idg_offset ; j_off = g%jdg_offset
3658 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
3659 ((j+j_off) >= g%domain%njhalo+1))
then
3665 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
3666 ((i+i_off) >= g%domain%nihalo+1))
then
3668 if (i+i_off == g%domain%nihalo+1)
then
3671 at_west_bdry=.false.
3674 if (i+i_off == g%domain%niglobal+g%domain%nihalo)
then
3677 at_east_bdry=.false.
3680 if (hmask(i,j) == 1)
then
3682 dxh = g%dxT(i,j) ; dyh = g%dyT(i,j) ; dxdyh = g%areaT(i,j)
3684 h_after_uflux(i,j) = h0(i,j)
3686 stencil(:) = h0(i-2:i+2,j)
3692 if (cs%u_face_mask(i-1,j) == 4.)
then
3694 flux_diff_cell = flux_diff_cell + dyh * time_step * cs%u_flux_bdry_val(i-1,j) * &
3695 cs%t_bdry_val(i-1,j) / dxdyh
3699 u_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i-1,j))
3701 if (u_face > 0)
then
3705 if (at_west_bdry .AND. (hmask(i-1,j) == 3))
then
3707 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step * stencil(-1) / dxdyh
3709 elseif (hmask(i-1,j) * hmask(i-2,j) == 1)
then
3710 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
3711 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh* time_step / dxdyh * &
3712 (stencil(-1) - phi * (stencil(-1)-stencil(0))/2)
3718 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step / dxdyh * stencil(-1)
3722 elseif (u_face < 0)
then
3723 if (hmask(i-1,j) * hmask(i+1,j) == 1)
then
3724 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
3725 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * &
3726 (stencil(0) - phi * (stencil(0)-stencil(-1))/2)
3729 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * stencil(0)
3731 if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2))
then
3732 flux_enter(i-1,j,2) = abs(u_face) * dyh * time_step * stencil(0)
3742 if (cs%u_face_mask(i+1,j) == 4.)
then
3744 flux_diff_cell = flux_diff_cell + dyh * time_step * cs%u_flux_bdry_val(i+1,j) *&
3745 cs%t_bdry_val(i+1,j)/ dxdyh
3748 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
3750 if (u_face < 0)
then
3752 if (at_east_bdry .AND. (hmask(i+1,j) == 3))
then
3755 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step * stencil(1) / dxdyh
3757 elseif (hmask(i+1,j) * hmask(i+2,j) == 1)
then
3759 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
3760 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step / dxdyh * &
3761 (stencil(1) - phi * (stencil(1)-stencil(0))/2)
3767 flux_diff_cell = flux_diff_cell + abs(u_face) * dyh * time_step / dxdyh * stencil(1)
3771 elseif (u_face > 0)
then
3773 if (hmask(i-1,j) * hmask(i+1,j) == 1)
then
3775 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
3776 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * &
3777 (stencil(0) - phi * (stencil(0)-stencil(1))/2)
3783 flux_diff_cell = flux_diff_cell - abs(u_face) * dyh * time_step / dxdyh * stencil(0)
3785 if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2))
then
3787 flux_enter(i+1,j,1) = abs(u_face) * dyh * time_step * stencil(0)
3794 h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell
3798 elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2))
then
3800 if (at_west_bdry .AND. (hmask(i-1,j) == 3))
then
3801 u_face = 0.5 * (cs%u_shelf(i-1,j-1) + cs%u_shelf(i-1,j))
3802 flux_enter(i,j,1) = abs(u_face) * g%dyT(i,j) * time_step * cs%t_bdry_val(i-1,j)* &
3803 cs%thickness_bdry_val(i+1,j)
3804 elseif (cs%u_face_mask(i-1,j) == 4.)
then
3805 flux_enter(i,j,1) = g%dyT(i,j) * time_step * cs%u_flux_bdry_val(i-1,j)*cs%t_bdry_val(i-1,j)
3808 if (at_east_bdry .AND. (hmask(i+1,j) == 3))
then
3809 u_face = 0.5 * (cs%u_shelf(i,j-1) + cs%u_shelf(i,j))
3810 flux_enter(i,j,2) = abs(u_face) * g%dyT(i,j) * time_step * cs%t_bdry_val(i+1,j)* &
3811 cs%thickness_bdry_val(i+1,j)
3812 elseif (cs%u_face_mask(i+1,j) == 4.)
then
3813 flux_enter(i,j,2) = g%dyT(i,j) * time_step * cs%u_flux_bdry_val(i+1,j) * cs%t_bdry_val(i+1,j)
3839 end subroutine ice_shelf_advect_temp_x
3841 subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter)
3844 real,
intent(in) :: time_step
3845 real,
dimension(SZDI_(G),SZDJ_(G)), &
3848 real,
dimension(SZDI_(G),SZDJ_(G)), &
3849 intent(in) :: h_after_uflux
3851 real,
dimension(SZDI_(G),SZDJ_(G)), &
3852 intent(inout) :: h_after_vflux
3854 real,
dimension(SZDI_(G),SZDJ_(G),4), &
3855 intent(inout) :: flux_enter
3876 integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied
3877 integer :: i_off, j_off
3878 logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry
3879 real,
dimension(-2:2) :: stencil
3881 flux_diff_cell, phi, dxh, dyh, dxdyh
3882 character(len=1) :: debug_str
3884 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
3885 i_off = g%idg_offset ; j_off = g%jdg_offset
3888 if (((i+i_off) <= g%domain%niglobal+g%domain%nihalo) .AND. &
3889 ((i+i_off) >= g%domain%nihalo+1))
then
3895 if (((j+j_off) <= g%domain%njglobal+g%domain%njhalo) .AND. &
3896 ((j+j_off) >= g%domain%njhalo+1))
then
3898 if (j+j_off == g%domain%njhalo+1)
then
3899 at_south_bdry=.true.
3901 at_south_bdry=.false.
3903 if (j+j_off == g%domain%njglobal+g%domain%njhalo)
then
3904 at_north_bdry=.true.
3906 at_north_bdry=.false.
3909 if (hmask(i,j) == 1)
then
3910 dxh = g%dxT(i,j) ; dyh = g%dyT(i,j) ; dxdyh = g%areaT(i,j)
3911 h_after_vflux(i,j) = h_after_uflux(i,j)
3913 stencil(:) = h_after_uflux(i,j-2:j+2)
3918 if (cs%v_face_mask(i,j-1) == 4.)
then
3920 flux_diff_cell = flux_diff_cell + dxh * time_step * cs%v_flux_bdry_val(i,j-1) * &
3921 cs%t_bdry_val(i,j-1)/ dxdyh
3925 v_face = 0.5 * (cs%v_shelf(i-1,j-1) + cs%v_shelf(i,j-1))
3927 if (v_face > 0)
then
3931 if (at_south_bdry .AND. (hmask(i,j-1) == 3))
then
3933 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step * stencil(-1) / dxdyh
3935 elseif (hmask(i,j-1) * hmask(i,j-2) == 1)
then
3937 phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1))
3938 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * &
3939 (stencil(-1) - phi * (stencil(-1)-stencil(0))/2)
3944 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * stencil(-1)
3947 elseif (v_face < 0)
then
3949 if (hmask(i,j-1) * hmask(i,j+1) == 1)
then
3950 phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0))
3951 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * &
3952 (stencil(0) - phi * (stencil(0)-stencil(-1))/2)
3954 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * stencil(0)
3956 if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2))
then
3957 flux_enter(i,j-1,4) = abs(v_face) * dyh * time_step * stencil(0)
3968 if (cs%v_face_mask(i,j+1) == 4.)
then
3970 flux_diff_cell = flux_diff_cell + dxh * time_step * cs%v_flux_bdry_val(i,j+1) *&
3971 cs%t_bdry_val(i,j+1)/ dxdyh
3975 v_face = 0.5 * (cs%v_shelf(i-1,j) + cs%v_shelf(i,j))
3977 if (v_face < 0)
then
3979 if (at_north_bdry .AND. (hmask(i,j+1) == 3))
then
3981 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step * stencil(1) / dxdyh
3982 elseif (hmask(i,j+1) * hmask(i,j+2) == 1)
then
3983 phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1))
3984 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * &
3985 (stencil(1) - phi * (stencil(1)-stencil(0))/2)
3989 flux_diff_cell = flux_diff_cell + abs(v_face) * dxh * time_step / dxdyh * stencil(1)
3992 elseif (v_face > 0)
then
3994 if (hmask(i,j-1) * hmask(i,j+1) == 1)
then
3995 phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0))
3996 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * &
3997 (stencil(0) - phi * (stencil(0)-stencil(1))/2)
4001 flux_diff_cell = flux_diff_cell - abs(v_face) * dxh * time_step / dxdyh * stencil(0)
4002 if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2))
then
4003 flux_enter(i,j+1,3) = abs(v_face) * dxh * time_step * stencil(0)
4011 h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell
4013 elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2))
then
4015 if (at_south_bdry .AND. (hmask(i,j-1) == 3))
then
4016 v_face = 0.5 * (cs%v_shelf(i-1,j-1) + cs%v_shelf(i,j-1))
4017 flux_enter(i,j,3) = abs(v_face) * g%dxT(i,j) * time_step * cs%t_bdry_val(i,j-1)* &
4018 cs%thickness_bdry_val(i,j-1)
4019 elseif (cs%v_face_mask(i,j-1) == 4.)
then
4020 flux_enter(i,j,3) = g%dxT(i,j) * time_step * cs%v_flux_bdry_val(i,j-1)*cs%t_bdry_val(i,j-1)
4023 if (at_north_bdry .AND. (hmask(i,j+1) == 3))
then
4024 v_face = 0.5 * (cs%v_shelf(i-1,j) + cs%v_shelf(i,j))
4025 flux_enter(i,j,4) = abs(v_face) * g%dxT(i,j) * time_step * cs%t_bdry_val(i,j+1)* &
4026 cs%thickness_bdry_val(i,j+1)
4027 elseif (cs%v_face_mask(i,j+1) == 4.)
then
4028 flux_enter(i,j,4) = g%dxT(i,j) * time_step * cs%v_flux_bdry_val(i,j+1)*cs%t_bdry_val(i,j+1)
4049 end subroutine ice_shelf_advect_temp_y